Implement define-unparser-method and define-pp-describer as deferred actions.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 0b24943a097f296156240409deffcd3edd49a992..0f6222fb21b4816304203737feaeff5b8ef122f2 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -73,55 +73,6 @@ USA.
    (fix:and limit-mask (get-interrupt-enables))
    procedure))
 \f
-;;;; Printing
-
-(define (unparser-method? object)
-  (and (procedure? object)
-       (procedure-arity-valid? object 2)))
-
-(define (general-unparser-method procedure)
-  (lambda (state object)
-    (with-current-unparser-state state
-      (lambda (port)
-       (if (get-param:unparse-with-maximum-readability?)
-           (begin
-             (write-string "#@" port)
-             (write (object-hash object) port))
-           (procedure object port))))))
-
-(define (bracketed-unparser-method procedure)
-  (general-unparser-method
-   (lambda (object port)
-     (write-string "#[" port)
-     (procedure object port)
-     (write-char #\] port))))
-
-(define (standard-unparser-method name procedure)
-  (bracketed-unparser-method
-   (lambda (object port)
-     (display (if (procedure? name)
-                 (name object)
-                 name)
-             port)
-     (write-char #\space port)
-     (write (object-hash object) port)
-     (if procedure (procedure object port)))))
-
-(define (simple-unparser-method name get-parts)
-  (standard-unparser-method name
-    (and get-parts
-        (lambda (object port)
-          (for-each (lambda (object)
-                      (write-char #\space port)
-                      (write object port))
-                    (get-parts object))))))
-
-(define (simple-parser-method procedure)
-  (lambda (objects lose)
-    (or (and (pair? (cdr objects))
-            (procedure (cddr objects)))
-       (lose))))
-\f
 ;;;; Boot-time initializers
 
 (define (init-boot-inits!)
@@ -199,6 +150,65 @@ USA.
 (define saved-boot-inits '())
 (define boot-action-groups '())
 \f
+;;;; Printing
+
+(define (define-unparser-method predicate unparser)
+  (defer-boot-action 'unparser-methods
+    (lambda ()
+      (define-unparser-method predicate unparser))))
+
+(define (define-pp-describer predicate describer)
+  (defer-boot-action 'pp-describers
+    (lambda ()
+      (define-pp-describer predicate describer))))
+
+(define (unparser-method? object)
+  (and (procedure? object)
+       (procedure-arity-valid? object 2)))
+
+(define (general-unparser-method procedure)
+  (lambda (state object)
+    (with-current-unparser-state state
+      (lambda (port)
+       (if (get-param:unparse-with-maximum-readability?)
+           (begin
+             (write-string "#@" port)
+             (write (object-hash object) port))
+           (procedure object port))))))
+
+(define (bracketed-unparser-method procedure)
+  (general-unparser-method
+   (lambda (object port)
+     (write-string "#[" port)
+     (procedure object port)
+     (write-char #\] port))))
+
+(define (standard-unparser-method name procedure)
+  (bracketed-unparser-method
+   (lambda (object port)
+     (display (if (procedure? name)
+                 (name object)
+                 name)
+             port)
+     (write-char #\space port)
+     (write (object-hash object) port)
+     (if procedure (procedure object port)))))
+
+(define (simple-unparser-method name get-parts)
+  (standard-unparser-method name
+    (and get-parts
+        (lambda (object port)
+          (for-each (lambda (object)
+                      (write-char #\space port)
+                      (write object port))
+                    (get-parts object))))))
+
+(define (simple-parser-method procedure)
+  (lambda (objects lose)
+    (or (and (pair? (cdr objects))
+            (procedure (cddr objects)))
+       (lose))))
+\f
 ;;;; Miscellany
 
 (define (object-constant? object)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e2deda884a6974abdc9338674907170fd0d537c9..5fa235215e107e62258f5e426697438531af79a9 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -139,6 +139,8 @@ USA.
          bytes-per-object
          default-object
          default-object?
+         define-pp-describer
+         define-unparser-method
          gc-space-status
          general-unparser-method
          interrupt-bit/after-gc