exported pretty-format, a parameter maker for setting the pretty

format for various forms.  The pretty format structure is not
documented yet and there is no error-checking mechanism for
verifying proper input.

scheme/ikarus.pretty-print.ss

@@ -15,10 +15,10 @@
 
 
 (library (ikarus pretty-print)
-  (export pretty-print pretty-width)
+  (export pretty-print pretty-width pretty-format)
   (import 
     (rnrs hashtables)
-    (except (ikarus) pretty-print pretty-width))
+    (except (ikarus) pretty-print pretty-width pretty-format))
   (define (map1ltr f ls)
     ;;; ltr so that gensym counts get assigned properly
     (cond
@@ -609,6 +609,15 @@
        (if (output-port? p)
            (pretty x p)
            (die 'pretty-print "not an output port" p))]))
+
+  (define pretty-format
+    (lambda (x)
+      (unless (symbol? x)
+        (die 'pretty-format "not a symbol" x))
+      (case-lambda
+        [() (getprop x '*pretty-format*)]
+        [(v) (putprop x '*pretty-format* v)])))
+
   ;;; standard formats
   (set-fmt! 'quote '(read-macro . "'"))
   (set-fmt! 'unquote '(read-macro . ","))

scheme/ikarus.writer.ss

@@ -449,22 +449,20 @@
   
   (define macro
     (lambda (x h)
-      (define macro-forms
-        '([quote .             "'"]
-          [quasiquote .        "`"]
-          [unquote .           ","]
-          [unquote-splicing .  ",@"]
-          [syntax .            "#'"]
-          [quasisyntax .       "#`"]
-          [unsyntax .          "#,"]
-          [unsyntax-splicing . "#,@"]
-          [|#primitive| .     "#%"]))
-      (and (pair? x)
+      (and 
+        (pair? x)
+        (let ([a ($car x)])
+          (and
+            (symbol? a)
             (let ([d ($cdr x)])
               (and (pair? d)
                 (null? ($cdr d))
                 (not (hashtable-ref h x #f))))
-           (assq ($car x) macro-forms))))
+            (let ([p ((pretty-format a))])
+              (and (pair? p)
+                (eq? (car p) 'read-macro)
+                (string? (cdr p)))
+                p))))))
   
   (define write-pair
     (lambda (x p m h i)

scheme/last-revision

@@ -1 +1 @@
-1471
+1472

scheme/makefile.ss

@@ -1285,6 +1285,7 @@
     [set-symbol-value!                           i symbols $boot]
     [eval-core                                   $boot]
     [pretty-print                                i $boot]
+    [pretty-format                               i]
     [pretty-width                                i]
     [module                                      i cm]
     [library                                     i]