From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 04:23:21 +0000 (-0700)
Subject: Major refactor to how printer methods work.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~62
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8a888d9cfd986cb2dd8ebd2e865971f593007cb2;p=mit-scheme.git

Major refactor to how printer methods work.

* Replaced define-unparser-method with define-print-method.  A print method is
  an ordinary procedure that accepts an object and an output port as its
  arguments and prints whatever it wants to.  The translation layer required by
  older unparser methods is no longer needed.

* New standard-print-method is roughly equivalent to simple-unparser-method.

* New bracketed-print-method is roughly equivalent to standard-unparser-method.

* Changed the printer to handle standard-print-method specially when detecting
  cycles and shared structure, so that an object using that print method has its
  parts walked when looking for shared/cyclic structure.
---

diff --git a/src/compiler/base/blocks.scm b/src/compiler/base/blocks.scm
index 6b9e4230e..fdb904053 100644
--- a/src/compiler/base/blocks.scm
+++ b/src/compiler/base/blocks.scm
@@ -113,7 +113,7 @@ from the continuation, and then "glued" into place afterwards.
     block))
 
 (define-vector-tag-unparser block-tag
-  (simple-unparser-method "LIAR:block"
+  (standard-print-method "LIAR:block"
     (lambda (block)
       (cons (enumeration/index->name block-types (block-type block))
 	    (let ((procedure (block-procedure block)))
diff --git a/src/compiler/base/ctypes.scm b/src/compiler/base/ctypes.scm
index feb28518a..fed668187 100644
--- a/src/compiler/base/ctypes.scm
+++ b/src/compiler/base/ctypes.scm
@@ -59,7 +59,7 @@ USA.
     (make-scfg application '())))
 
 (define-vector-tag-unparser application-tag
-  (simple-unparser-method
+  (standard-print-method
    (lambda (application)
      (case (application-type application)
        ((COMBINATION) "LIAR:combination")
diff --git a/src/compiler/base/enumer.scm b/src/compiler/base/enumer.scm
index 1bc378d44..d4aee06a1 100644
--- a/src/compiler/base/enumer.scm
+++ b/src/compiler/base/enumer.scm
@@ -38,7 +38,7 @@ USA.
 (define-structure (enumerand
 		   (conc-name enumerand/)
 		   (print-procedure
-		    (simple-unparser-method "LIAR:enumerand"
+		    (standard-print-method "LIAR:enumerand"
 		      (lambda (enumerand)
 			(list (enumerand/name enumerand))))))
   (enumeration false read-only true)
diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm
index 2f9a4f8f4..bdec69508 100644
--- a/src/compiler/base/lvalue.scm
+++ b/src/compiler/base/lvalue.scm
@@ -98,7 +98,7 @@ USA.
       (variable-normal-offset variable)))
 
 (define-vector-tag-unparser variable-tag
-  (simple-unparser-method "LIAR:variable"
+  (standard-print-method "LIAR:variable"
     (lambda (variable)
       (list (variable-name variable)))))
 
diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 1ff8c1828..ccf952481 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -46,10 +46,9 @@ USA.
   (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
     (set-vector-tag-%unparser!
      root-tag
-     (simple-unparser-method
+     (standard-print-method
       (lambda (object)
-	(string "LIAR:" (vector-tag-name (tagged-vector/tag object))))
-      #f))
+	(string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
     (named-lambda (make-vector-tag parent name enumeration)
       (let ((tag
 	     (%make-vector-tag (or parent root-tag)
diff --git a/src/compiler/base/proced.scm b/src/compiler/base/proced.scm
index 98f117444..77d0786ac 100644
--- a/src/compiler/base/proced.scm
+++ b/src/compiler/base/proced.scm
@@ -108,7 +108,7 @@ USA.
 	 (lambda (procedure)
 	   (enumeration/index->name continuation-types
 				    (procedure-type procedure)))))
-    (simple-unparser-method
+    (standard-print-method
      (lambda (procedure)
        (if (eq? (get-type procedure) 'PROCEDURE)
 	   "LIAR:procedure"
diff --git a/src/compiler/base/rvalue.scm b/src/compiler/base/rvalue.scm
index 556dc5f0f..7b3621cfe 100644
--- a/src/compiler/base/rvalue.scm
+++ b/src/compiler/base/rvalue.scm
@@ -96,7 +96,7 @@ USA.
 	  constant))))
 
 (define-vector-tag-unparser constant-tag
-  (simple-unparser-method "LIAR:constant"
+  (standard-print-method "LIAR:constant"
     (lambda (constant)
       (list (constant-value constant)))))
 
@@ -114,7 +114,7 @@ USA.
   (make-rvalue reference-tag block lvalue safe?))
 
 (define-vector-tag-unparser reference-tag
-  (simple-unparser-method "LIAR:reference"
+  (standard-print-method "LIAR:reference"
     (lambda (reference)
       (list (variable-name (reference-lvalue reference))))))
 
@@ -150,7 +150,7 @@ USA.
   (make-rvalue unassigned-test-tag block lvalue))
 
 (define-vector-tag-unparser unassigned-test-tag
-  (simple-unparser-method "LIAR:unassigned-test"
+  (standard-print-method "LIAR:unassigned-test"
     (lambda (unassigned-test)
       (list (unassigned-test-lvalue unassigned-test)))))
 
diff --git a/src/compiler/base/subprb.scm b/src/compiler/base/subprb.scm
index 64fafacb7..e314c3b49 100644
--- a/src/compiler/base/subprb.scm
+++ b/src/compiler/base/subprb.scm
@@ -114,7 +114,7 @@ known that the continuation need not be used.
 		   (constructor virtual-continuation/%make)
 		   (conc-name virtual-continuation/)
 		   (print-procedure
-		    (simple-unparser-method "LIAR:virtual-continuation"
+		    (standard-print-method "LIAR:virtual-continuation"
 		      (lambda (continuation)
 			(let ((type (virtual-continuation/type continuation)))
 			  (if type
diff --git a/src/compiler/rtlbase/rtlobj.scm b/src/compiler/rtlbase/rtlobj.scm
index 1de11688b..b4c4fdfd4 100644
--- a/src/compiler/rtlbase/rtlobj.scm
+++ b/src/compiler/rtlbase/rtlobj.scm
@@ -33,7 +33,7 @@ USA.
 		   (constructor make-rtl-expr
 				(rgraph label entry-edge debugging-info))
 		   (print-procedure
-		    (simple-unparser-method "LIAR:rtl-expr"
+		    (standard-print-method "LIAR:rtl-expr"
 		      (lambda (expression)
 			(list (rtl-expr/label expression))))))
   (rgraph false read-only true)
@@ -53,7 +53,7 @@ USA.
 					debugging-info
 					next-continuation-offset stack-leaf?))
 		   (print-procedure
-		    (simple-unparser-method "LIAR:rtl-procedure"
+		    (standard-print-method "LIAR:rtl-procedure"
 		      (lambda (procedure)
 			(list (rtl-procedure/label procedure))))))
   (rgraph false read-only true)
@@ -87,7 +87,7 @@ USA.
 					next-continuation-offset
 					debugging-info))
 		   (print-procedure
-		    (simple-unparser-method "LIAR:rtl-continuation"
+		    (standard-print-method "LIAR:rtl-continuation"
 		      (lambda (continuation)
 			(list (rtl-continuation/label continuation))))))
   (rgraph false read-only true)
diff --git a/src/compiler/rtlbase/valclass.scm b/src/compiler/rtlbase/valclass.scm
index 0c5fad011..df7bd08ac 100644
--- a/src/compiler/rtlbase/valclass.scm
+++ b/src/compiler/rtlbase/valclass.scm
@@ -32,7 +32,7 @@ USA.
 		   (conc-name value-class/)
 		   (constructor %make-value-class (name parent))
 		   (print-procedure
-		    (simple-unparser-method 'VALUE-CLASS
+		    (standard-print-method 'VALUE-CLASS
 		      (lambda (class)
 			(list (value-class/name class))))))
   (name false read-only true)
diff --git a/src/compiler/rtlopt/rcseht.scm b/src/compiler/rtlopt/rcseht.scm
index a578b6eb7..fdc655ffc 100644
--- a/src/compiler/rtlopt/rcseht.scm
+++ b/src/compiler/rtlopt/rcseht.scm
@@ -47,7 +47,7 @@ USA.
 (define-structure (element
 		   (constructor %make-element)
 		   (constructor make-element (expression))
-		   (print-procedure (simple-unparser-method "LIAR:element" #f)))
+		   (print-procedure (standard-print-method "LIAR:element")))
   (expression false read-only true)
   (cost false)
   (in-memory? false)
diff --git a/src/compiler/rtlopt/rcserq.scm b/src/compiler/rtlopt/rcserq.scm
index bf5e5467d..51f87db5b 100644
--- a/src/compiler/rtlopt/rcserq.scm
+++ b/src/compiler/rtlopt/rcserq.scm
@@ -32,7 +32,7 @@ USA.
 (define-structure (quantity
 		   (copier quantity-copy)
 		   (print-procedure
-		    (simple-unparser-method "LIAR:quantity" #f)))
+		    (standard-print-method "LIAR:quantity")))
   (number false read-only true)
   (first-register false)
   (last-register false))
diff --git a/src/compiler/rtlopt/rdflow.scm b/src/compiler/rtlopt/rdflow.scm
index b0742afaf..6e08a6e39 100644
--- a/src/compiler/rtlopt/rdflow.scm
+++ b/src/compiler/rtlopt/rdflow.scm
@@ -72,7 +72,7 @@ USA.
 		   (conc-name rnode/)
 		   (constructor make-rnode (register))
 		   (print-procedure
-		    (simple-unparser-method 'RNODE
+		    (standard-print-method 'RNODE
 		      (lambda (rnode)
 			(list (rnode/register rnode))))))
   (register false read-only true)
diff --git a/src/cref/object.scm b/src/cref/object.scm
index f6956190c..f2706bc09 100644
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -51,7 +51,7 @@ USA.
 		   (constructor make-package (name parent))
 		   (conc-name package/)
 		   (print-procedure
-		    (simple-unparser-method 'package
+		    (standard-print-method 'package
 		      (lambda (package)
 			(list (package/name package))))))
   (name #f read-only #t)
@@ -107,7 +107,7 @@ USA.
 		   (constructor %make-binding (package name value-cell new?))
 		   (conc-name binding/)
 		   (print-procedure
-		    (simple-unparser-method 'binding
+		    (standard-print-method 'binding
 		      (lambda (binding)
 			(list (binding/name binding)
 			      (package/name (binding/package binding)))))))
@@ -170,7 +170,7 @@ USA.
 		   (constructor %make-reference (package name))
 		   (conc-name reference/)
 		   (print-procedure
-		    (simple-unparser-method 'reference
+		    (standard-print-method 'reference
 		      (lambda (reference)
 			(list (reference/name reference)
 			      (package/name (reference/package reference)))))))
diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm
index df8024479..1ecc3af5d 100644
--- a/src/edwin/artdebug.scm
+++ b/src/edwin/artdebug.scm
@@ -974,10 +974,9 @@ Prefix argument means do not kill the debugger buffer."
 (define-structure (unparser-literal
 		   (conc-name unparser-literal/)
 		   (print-procedure
-		    (general-unparser-method
-		     (lambda (instance port)
-		       (write-string (unparser-literal/string instance)
-				     port))))
+		    (lambda (instance port)
+		      (write-string (unparser-literal/string instance)
+				    port)))
 		   (constructor unparser-literal/make))
   string)
 
diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm
index d529a8a8c..ae36ce26e 100644
--- a/src/edwin/bufwin.scm
+++ b/src/edwin/bufwin.scm
@@ -501,7 +501,7 @@ USA.
 (define-structure (outline
 		   (constructor %make-outline)
 		   (print-procedure
-		    (standard-unparser-method 'OUTLINE
+		    (bracketed-print-method 'OUTLINE
 		      (lambda (outline port)
 			(write-string "index: " port)
 			(write (outline-index-length outline) port)
@@ -569,7 +569,7 @@ USA.
 (define-structure (o3
 		   (constructor %make-o3)
 		   (print-procedure
-		    (standard-unparser-method 'O3
+		    (bracketed-print-method 'O3
 		      (lambda (o3 port)
 			(write-string "index: " port)
 			(write (o3-index o3) port)
diff --git a/src/edwin/calias.scm b/src/edwin/calias.scm
index ec0e35701..be5c33efc 100644
--- a/src/edwin/calias.scm
+++ b/src/edwin/calias.scm
@@ -217,11 +217,9 @@ USA.
 (define-structure (special-key (constructor %make-special-key)
 			       (conc-name special-key/)
 			       (print-procedure
-				(standard-unparser-method 'special-key
-				  (lambda (key port)
-				    (write-char #\space port)
-				    (write-string (special-key/name key)
-						  port)))))
+				(standard-print-method 'special-key
+				  (lambda (key)
+				    (list (special-key/name key))))))
   (symbol #f read-only #t)
   (bucky-bits #f read-only #t))
 
diff --git a/src/edwin/clscon.scm b/src/edwin/clscon.scm
index 1b07c78b7..7e9887c3b 100644
--- a/src/edwin/clscon.scm
+++ b/src/edwin/clscon.scm
@@ -57,7 +57,7 @@ USA.
 		  (list->vector (map car transforms))
 		  (list->vector (map cdr transforms))
 		  (make-vector (length transforms) (lambda () #f))
-		  (standard-unparser-method name #f)
+		  (standard-print-method name)
 		  class
 		  object-size))
 	       class))))
diff --git a/src/edwin/comman.scm b/src/edwin/comman.scm
index 345ca6e7e..b237842d8 100644
--- a/src/edwin/comman.scm
+++ b/src/edwin/comman.scm
@@ -31,7 +31,7 @@ USA.
 (define-structure (command
 		   (constructor %make-command ())
 		   (print-procedure
-		    (simple-unparser-method 'COMMAND
+		    (standard-print-method 'COMMAND
 		      (lambda (command)
 			(list (command-name command))))))
   name
@@ -103,7 +103,7 @@ USA.
 (define-structure (variable
 		   (constructor %make-variable ())
 		   (print-procedure
-		    (simple-unparser-method 'VARIABLE
+		    (standard-print-method 'VARIABLE
 		      (lambda (variable)
 			(list (variable-name variable))))))
   name
diff --git a/src/edwin/display.scm b/src/edwin/display.scm
index a6cd0556a..32f92d75c 100644
--- a/src/edwin/display.scm
+++ b/src/edwin/display.scm
@@ -33,7 +33,7 @@ USA.
 		   (conc-name display-type/)
 		   (constructor %make-display-type)
 		   (print-procedure
-		    (simple-unparser-method 'DISPLAY-TYPE
+		    (standard-print-method 'DISPLAY-TYPE
 		      (lambda (display-type)
 			(list (display-type/name display-type))))))
   (name false read-only true)
diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm
index 2f9deb0d5..9c7e9e83e 100644
--- a/src/edwin/editor.scm
+++ b/src/edwin/editor.scm
@@ -443,11 +443,9 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
 		   (constructor make-input-event (type operator . operands))
 		   (conc-name input-event/)
 		   (print-procedure
-		    (standard-unparser-method
-		     'input-event
-		     (lambda (event port)
-		       (write-char #\space port)
-		       (write (input-event/type event) port)))))
+		    (standard-print-method 'input-event
+		      (lambda (event)
+			(list (input-event/type event))))))
   (type #f read-only #t)
   (operator #f read-only #t)
   (operands #f read-only #t))
diff --git a/src/edwin/edtstr.scm b/src/edwin/edtstr.scm
index 7f9e9588f..6d07c46c3 100644
--- a/src/edwin/edtstr.scm
+++ b/src/edwin/edtstr.scm
@@ -129,8 +129,8 @@ USA.
 (define (button-name button)
   (symbol->string (button-symbol button)))
 
-(define-unparser-method button?
-  (simple-unparser-method (record-type-name <button>)
+(define-print-method button?
+  (standard-print-method (record-type-name <button>)
     (lambda (button)
       (list (button-symbol button)))))
 
diff --git a/src/edwin/keyparse.scm b/src/edwin/keyparse.scm
index e84764a95..eb26d7cb8 100644
--- a/src/edwin/keyparse.scm
+++ b/src/edwin/keyparse.scm
@@ -120,7 +120,7 @@ USA.
 		   (keyword-constructor make-keyparser-fragment)
 		   (conc-name keyparser-fragment/)
 		   (print-procedure
-		    (simple-unparser-method 'KEYPARSER-FRAGMENT
+		    (standard-print-method 'KEYPARSER-FRAGMENT
 		      (lambda (fragment)
 			(list (keyparser-fragment/keyword fragment))))))
   ;; Keyword that introduces the structure.
@@ -325,7 +325,7 @@ See \\[complete-keyword]."
 (define-structure (keyparser-stack-entry
 		   (conc-name keyparser-stack-entry/)
 		   (print-procedure
-		    (simple-unparser-method 'KEYPARSER-STACK-ENTRY
+		    (standard-print-method 'KEYPARSER-STACK-ENTRY
 		      (lambda (entry)
 			(list (keyparser-stack-entry/keyword entry))))))
   (pattern #f read-only #t)
diff --git a/src/edwin/modes.scm b/src/edwin/modes.scm
index 96cc943e5..675f17e7c 100644
--- a/src/edwin/modes.scm
+++ b/src/edwin/modes.scm
@@ -33,7 +33,7 @@ USA.
 				(name major? display-name super-mode
 				      %description initialization comtabs))
 		   (print-procedure
-		    (simple-unparser-method 'MODE
+		    (standard-print-method 'MODE
 		      (lambda (mode)
 			(cons (mode-name mode)
 			      (if (mode-major? mode)
diff --git a/src/edwin/struct.scm b/src/edwin/struct.scm
index 2080c6bd4..9042b967a 100644
--- a/src/edwin/struct.scm
+++ b/src/edwin/struct.scm
@@ -296,7 +296,7 @@ USA.
 (define-structure (mark
 		   (constructor make-temporary-mark)
 		   (print-procedure
-		    (simple-unparser-method 'MARK
+		    (standard-print-method 'MARK
 		      (lambda (mark)
 			(list (or (mark-buffer mark)
 				  (mark-group mark))
diff --git a/src/edwin/window.scm b/src/edwin/window.scm
index b5dfb8701..84f744d0f 100644
--- a/src/edwin/window.scm
+++ b/src/edwin/window.scm
@@ -364,7 +364,7 @@ USA.
   (vector-set! inferior 4 redisplay-flags))
 
 (unparser/set-tagged-vector-method! %inferior-tag
-  (standard-unparser-method 'INFERIOR
+  (bracketed-print-method 'INFERIOR
     (lambda (inferior port)
       (write-string " " port)
       (write (inferior-window inferior) port)
diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm
index f806cd73e..2e0294346 100644
--- a/src/gdbm/gdbm.scm
+++ b/src/gdbm/gdbm.scm
@@ -289,7 +289,7 @@ USA.
 
 (define-structure (gdbf (constructor make-gdbf)
 			(print-procedure
-			 (simple-unparser-method 'GDBF
+			 (standard-print-method 'GDBF
 			   (lambda (gdbf)
 			     (list (gdbf-filename gdbf))))))
   ;; Note that communicating through this malloced-per-GDBM_FILE
diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm
index fe590f569..ec4e7f9f7 100644
--- a/src/imail/imail-core.scm
+++ b/src/imail/imail-core.scm
@@ -968,7 +968,7 @@ USA.
 		   (safe-accessors #t)
 		   (constructor #f)
 		   (print-procedure
-		    (simple-unparser-method 'HEADER-FIELD
+		    (standard-print-method 'HEADER-FIELD
 		      (lambda (header)
 			(list (header-field-name header))))))
   (name #f read-only #t)
diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm
index 1857cbefe..3044bcb0e 100644
--- a/src/imail/imail-mime.scm
+++ b/src/imail/imail-mime.scm
@@ -753,7 +753,7 @@ USA.
 (define-structure (mime-encoding
                    (conc-name mime-encoding/)
                    (print-procedure
-                    (simple-unparser-method 'MIME-ENCODING
+                    (standard-print-method 'MIME-ENCODING
                       (lambda (encoding)
                         (list (mime-encoding/name encoding)))))
                    (constructor %make-mime-encoding))
diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 0c709420b..8d8611756 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -92,14 +92,13 @@ USA.
 		     '<= binary-input-port?
 		     '<= binary-output-port?)
 
-(define-unparser-method binary-port?
-  (standard-unparser-method
+(define-print-method binary-port?
+  (standard-print-method
    (lambda (port)
      (cond ((binary-i/o-port? port) 'binary-i/o-port)
 	   ((binary-input-port? port) 'binary-input-port)
 	   ((binary-output-port? port) 'binary-output-port)
-	   (else 'binary-port)))
-   #f))
+	   (else 'binary-port)))))
 
 ;;;; Bytevector input ports
 
diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 0b0d10c0a..ad39b5260 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -303,57 +303,59 @@ USA.
 
 ;;;; Printing
 
-(define (define-unparser-method predicate unparser)
-  (defer-boot-action 'unparser-methods
+(define (define-print-method predicate print-method)
+  (defer-boot-action 'print-methods
     (lambda ()
-      (define-unparser-method predicate unparser))))
+      (define-print-method predicate print-method))))
+
+(define (standard-print-method name #!optional get-parts)
+  (%record standard-print-method-tag
+	   name
+	   (if (and get-parts (not (default-object? get-parts)))
+	       get-parts
+	       (lambda (object)
+		 (declare (ignore object))
+		 '()))))
+
+;;; Would have used normal records here but the record abstraction is defined
+;;; after this is needed.
+
+(define (standard-print-method? object)
+  (and (%record? object)
+       (fix:= 3 (%record-length object))
+       (eq? standard-print-method-tag (%record-ref object 0))))
+
+(define (standard-print-method-name spm object)
+  (let ((name (%record-ref spm 1)))
+    (if (procedure? name)
+	(name object)
+	name)))
+
+(define (standard-print-method-parts spm object)
+  ((%record-ref spm 2) object))
+
+(define-integrable standard-print-method-tag
+  '|#[standard-print-method-tag]|)
+
+(define (bracketed-print-method name printer)
+  (lambda (object port)
+    (if (get-param:print-with-maximum-readability?)
+	(begin
+	  (write-string "#@" port)
+	  (write (hash-object object) port))
+	(begin
+	  (write-string "#[" port)
+	  (display (if (procedure? name) (name object) name) port)
+	  (write-char #\space port)
+	  (write (hash-object object) port)
+	  (if printer (printer object port))
+	  (write-char #\] port)))))
 
 (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:print-with-maximum-readability?)
-	    (begin
-	      (write-string "#@" port)
-	      (write (hash-object 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 (hash-object 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))
diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 2dc34a890..f2d398d6e 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -88,14 +88,15 @@ USA.
     bundle?
   (alist bundle-alist))
 
-(define-unparser-method bundle?
-  (standard-unparser-method
-   (lambda (bundle)
-     (record-type-name (record-type-descriptor bundle)))
-   (lambda (bundle port)
-     (let ((handler (bundle-ref bundle 'write-self #f)))
-       (if handler
-	   (handler port))))))
+(define-print-method bundle?
+  (standard-print-method
+      (lambda (bundle)
+	(record-type-name (record-type-descriptor bundle)))
+    (lambda (bundle)
+      (let ((handler (bundle-ref bundle 'summarize-self #f)))
+	(if handler
+	    (handler)
+	    '())))))
 
 (define-pp-describer bundle?
   (lambda (bundle)
diff --git a/src/runtime/condvar.scm b/src/runtime/condvar.scm
index 561f80bf1..6d0d9f5cc 100644
--- a/src/runtime/condvar.scm
+++ b/src/runtime/condvar.scm
@@ -34,7 +34,7 @@ USA.
 		   (constructor %make-condition-variable
 				(name waiter-head waiter-tail))
 		   (print-procedure
-		    (simple-unparser-method 'condition-variable
+		    (standard-print-method 'condition-variable
 		      (lambda (condvar)
 			(cond ((condition-variable-name condvar) => list)
 			      (else '()))))))
diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index 76cbccb41..339b4036b 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -291,9 +291,8 @@ differences:
   (symbol (parser-context/name context) '?))
 
 (define (default-unparser-text context)
-  `(,(absolute 'standard-unparser-method context)
-    ',(parser-context/name context)
-    #f))
+  `(,(absolute 'standard-print-method context)
+    ',(parser-context/name context)))
 
 (define (default-type-name context)
   (symbol 'rtd: (parser-context/name context)))
@@ -841,7 +840,7 @@ differences:
 	   (or (structure/record-type? structure)
 	       (structure/tagged? structure)))
       (let ((context (structure/context structure)))
-	`((define-unparser-method
+	`((define-print-method
 	    ,(close (structure/predicate structure) context)
 	    ,(close (structure/print-procedure structure) context))))
       '()))
\ No newline at end of file
diff --git a/src/runtime/dispatch-tag.scm b/src/runtime/dispatch-tag.scm
index b740c78c1..864fc5a9c 100644
--- a/src/runtime/dispatch-tag.scm
+++ b/src/runtime/dispatch-tag.scm
@@ -173,8 +173,8 @@ USA.
   (guarantee dispatch-tag? superset 'add-dispatch-tag-superset)
   (%add-to-weak-set superset (%tag-supersets tag)))
 
-(define-unparser-method dispatch-tag?
-  (simple-unparser-method
+(define-print-method dispatch-tag?
+  (standard-print-method
    (lambda (tag)
      (if (dispatch-metatag? tag) 'dispatch-metatag 'dispatch-tag))
    (lambda (tag)
diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index 34eaa756f..030c451e3 100644
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -36,10 +36,9 @@ USA.
 		   (constructor %make-condition-type
 				(name field-indexes number-of-fields reporter))
 		   (print-procedure
-		    (standard-unparser-method 'condition-type
-		      (lambda (type port)
-			(write-char #\space port)
-			(write-string (%condition-type/name type) port)))))
+		    (standard-print-method 'condition-type
+		      (lambda (type)
+			(list (%condition-type/name type))))))
   (name #f read-only #t)
   generalizations
   (field-indexes #f read-only #t)
@@ -65,7 +64,7 @@ USA.
 	       (compute-field-indexes generalization field-names))
 	   (lambda (n-fields field-indexes)
 	     (%make-condition-type
-	      (cond ((string? name) (string-copy name))
+	      (cond ((string? name) (string->immutable name))
 		    ((symbol? name) (symbol->string name))
 		    ((not name) "(anonymous)")
 		    (else
@@ -158,12 +157,10 @@ USA.
 		   (constructor %%make-condition
 				(type continuation restarts field-values))
 		   (print-procedure
-		    (standard-unparser-method 'condition
-		      (lambda (condition port)
-			(write-char #\space port)
-			(write-string
-			 (%condition-type/name (%condition/type condition))
-			 port)))))
+		    (standard-print-method 'condition
+		      (lambda (condition)
+			(list (%condition-type/name
+			       (%condition/type condition)))))))
   (type #f read-only #t)
   (continuation #f read-only #t)
   (restarts #f read-only #t)
@@ -312,13 +309,12 @@ USA.
 		   (constructor %make-restart
 				(name reporter effector interactor))
 		   (print-procedure
-		    (standard-unparser-method 'restart
-		      (lambda (restart port)
-			(write-char #\space port)
+		    (standard-print-method 'restart
+		      (lambda (restart)
 			(let ((name (%restart/name restart)))
 			  (if name
-			      (write name port)
-			      (write-string "(anonymous)" port)))))))
+			      (list name)
+			      '()))))))
   (name #f read-only #t)
   (reporter #f read-only #t)
   (effector #f read-only #t)
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 43b8a4a55..af3de3978 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -45,8 +45,8 @@ USA.
 ;; two digits representing a larger number, then RADIX is their base.
 (define %radix)
 
-(define-unparser-method alien?
-  (standard-unparser-method
+(define-print-method alien?
+  (bracketed-print-method
    'alien
    (lambda (alien port)
      (write-char #\space port)
@@ -182,7 +182,7 @@ USA.
 		   ;; To be fasdump/loadable.
 		   (type vector) (named 'alien-function)
 		   (print-procedure
-		    (standard-unparser-method 'alien-function
+		    (bracketed-print-method 'alien-function
 		     (lambda (alienf port)
 		       (write-char #\space port)
 		       (write-string (%alien-function/name alienf)
diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm
index 31290e6bc..176521001 100644
--- a/src/runtime/gdbm.scm
+++ b/src/runtime/gdbm.scm
@@ -118,7 +118,7 @@ USA.
 				    opt val)))
 
 (define-structure (gdbf
-		   (print-procedure (simple-unparser-method 'gdbf
+		   (print-procedure (standard-print-method 'gdbf
 				      (lambda (gdbf)
 					(list (gdbf-filename gdbf))))))
   descriptor
diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm
index 81c8e8140..be4096db3 100644
--- a/src/runtime/graphics.scm
+++ b/src/runtime/graphics.scm
@@ -53,7 +53,7 @@ USA.
 		     operation/set-line-style
 		     custom-operations))
 		   (print-procedure
-		    (simple-unparser-method 'graphics-type
+		    (standard-print-method 'graphics-type
 		      (lambda (type)
 			(list (graphics-device-type/name type))))))
   (name false read-only true)
diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index a9cac454b..956cf55c4 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -89,6 +89,15 @@ USA.
 				   (list (cons 'name name) ...)))))
 	      env))
 
+    (if (unbound? env 'standard-print-method)
+	(eval '(define (standard-print-method name #!optional get-parts)
+		 (simple-unparser-method name
+					 (if (default-object? get-parts)
+					     #f
+					     get-parts)))
+	      env))
+    (provide-rename env 'standard-unparser-method 'bracketed-print-method)
+
     (for-each (lambda (old-name)
 		(provide-rename env old-name (symbol 'scode- old-name)))
 	      '(access-environment
diff --git a/src/runtime/http-io.scm b/src/runtime/http-io.scm
index c4595fa5a..d55d1b897 100644
--- a/src/runtime/http-io.scm
+++ b/src/runtime/http-io.scm
@@ -49,8 +49,8 @@ USA.
       (guarantee-headers&body headers body 'make-http-request)
     (%make-http-request method uri version headers body)))
 
-(define-unparser-method http-request?
-  (simple-unparser-method 'http-request
+(define-print-method http-request?
+  (standard-print-method 'http-request
     (lambda (request)
       (list (http-request-method request)
 	    (uri->string (http-request-uri request))))))
@@ -72,8 +72,8 @@ USA.
       (guarantee-headers&body headers body 'make-http-response)
     (%make-http-response version status reason headers body)))
 
-(define-unparser-method http-response?
-  (simple-unparser-method 'http-response
+(define-print-method http-response?
+  (standard-print-method 'http-response
     (lambda (response)
       (list (http-response-status response)))))
 
diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm
index 14154b1c2..a5fbdebfc 100644
--- a/src/runtime/http-syntax.scm
+++ b/src/runtime/http-syntax.scm
@@ -234,8 +234,8 @@ USA.
 
 (define-guarantee http-header "HTTP header field")
 
-(define-unparser-method http-header?
-  (simple-unparser-method 'http-header
+(define-print-method http-header?
+  (standard-print-method 'http-header
     (lambda (header)
       (list (http-header-name header)))))
 
diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 7ba4a4e06..959eb33b7 100644
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -73,8 +73,8 @@ USA.
 	 (make-record-type "package" '(parent children name environment))))
     (set! package-tag rtd)
     (for-each (lambda (p) (%record-set! p 0 rtd)) *packages*)
-    (define-unparser-method (record-predicate rtd)
-      (simple-unparser-method 'package
+    (define-print-method (record-predicate rtd)
+      (standard-print-method 'package
 	(lambda (package)
 	  (list (package/name package)))))))
 
diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm
index 317234281..80294bb72 100644
--- a/src/runtime/pathname.scm
+++ b/src/runtime/pathname.scm
@@ -110,8 +110,8 @@ these rules:
 
 (define-guarantee pathname "pathname")
 
-(define-unparser-method pathname?
-  (simple-unparser-method 'pathname
+(define-print-method pathname?
+  (standard-print-method 'pathname
     (lambda (pathname)
       (list (->namestring pathname)))))
 
diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm
index f5bdca0ae..f1d233a33 100644
--- a/src/runtime/poplat.scm
+++ b/src/runtime/poplat.scm
@@ -38,7 +38,7 @@ USA.
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! population-tag
-				    (standard-unparser-method 'population #f)))
+				    (standard-print-method 'population)))
 
 (define bogus-false '(bogus-false))
 (define population-tag '(population))
diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 53d59cf0a..4ccbb2f15 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -238,8 +238,7 @@ USA.
 			'<= procedure?)
    (register-predicate! procedure-arity? 'procedure-arity)
    (register-predicate! thunk? 'thunk '<= procedure?)
-   (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
-   (register-predicate! unparser-method? 'unparser-method '<= procedure?)))
+   (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)))
 
 (add-boot-init!
  (lambda ()
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index e97bea5dc..5f3bf2e1a 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -246,7 +246,11 @@ USA.
   (let ((table (make-strong-eq-hash-table)))
 
     (define (walk object)
-      (cond ((pair? object)
+      (cond ((get-print-method-parts object)
+	     => (lambda (parts)
+		  (if (mark! object)
+		      (for-each walk parts))))
+	    ((pair? object)
 	     (if (mark! object)
 		 (begin
 		   (walk (car object))
@@ -283,24 +287,51 @@ USA.
     (print-number (cdr label) context)
     (*print-char (if def? #\= #\#) context)
     def?))
+
+(define (print-object-1 object context)
+  (let ((print-method (get-print-method object)))
+    (cond ((standard-print-method? print-method)
+	   (*print-with-brackets
+	    (standard-print-method-name print-method object)
+	    object
+	    context
+	    (lambda (context*)
+	      (for-each (lambda (part)
+			  (*print-char #\space context*)
+			  (print-object part context*))
+			(standard-print-method-parts print-method object)))))
+	  (print-method
+	   (parameterize* (list (cons initial-context context))
+	     (lambda ()
+	       (print-method object (context-port context)))))
+	  (else
+	   ((vector-ref dispatch-table
+			((ucode-primitive primitive-object-type 1) object))
+	    object
+	    context)))))
 
-(define-deferred print-object-1
-  (standard-predicate-dispatcher 'print-object-1 2))
+(define (get-print-method-parts object)
+  (let ((print-method (get-print-method object)))
+    (and (standard-print-method? print-method)
+	 (standard-print-method-parts print-method object))))
+
+(define-deferred get-print-method
+  (standard-predicate-dispatcher 'get-print-method 1))
 
 (add-boot-init!
  (lambda ()
-   (define-predicate-dispatch-default-handler print-object-1
-     (lambda (object context)
-       ((vector-ref dispatch-table
-		    ((ucode-primitive primitive-object-type 1) object))
-	object
-	context)))
-   (set! define-unparser-method
-	 (named-lambda (define-unparser-method predicate unparser)
-	   (define-predicate-dispatch-handler print-object-1
-	     (list predicate context?)
-	     unparser)))
-   (run-deferred-boot-actions 'unparser-methods)))
+   (set! define-print-method
+	 (named-lambda (define-print-method predicate print-method)
+	   (define-predicate-dispatch-handler get-print-method
+	     (list predicate)
+	     (lambda (object)
+	       (declare (ignore object))
+	       print-method))))
+   (define-predicate-dispatch-default-handler get-print-method
+     (lambda (object)
+       (declare (ignore object))
+       #f))
+   (run-deferred-boot-actions 'print-methods)))
 
 (define dispatch-table)
 (add-boot-init!
@@ -371,8 +402,7 @@ USA.
   (char-in-set? char (context-char-set context)))
 
 (define (*print-with-brackets name object context procedure)
-  (if (or (and (get-param:print-with-maximum-readability?) object)
-          (context-in-brackets? context))
+  (if (and (get-param:print-with-maximum-readability?) object)
       (*print-readable-hash object context)
       (begin
 	(*print-string "#[" context)
@@ -385,7 +415,6 @@ USA.
 		(*print-char #\space context*)
 		(*print-hash object context*)))
 	  (cond (procedure
-		 (*print-char #\space context*)
 		 (procedure context*))
 		((get-param:print-with-datum?)
 		 (*print-char #\space context*)
@@ -402,10 +431,12 @@ USA.
       ((non-pointer)
        (*print-with-brackets type object context
          (lambda (context*)
+	   (*print-char #\space context*)
            (*print-datum object context*))))
       (else                             ;UNDEFINED, GC-INTERNAL
        (*print-with-brackets type #f context
          (lambda (context*)
+	   (*print-char #\space context*)
            (*print-datum object context*)))))))
 
 (define (user-object-type object)
@@ -464,6 +495,7 @@ USA.
       (print-symbol-name (symbol->string symbol) context)
       (*print-with-brackets 'uninterned-symbol symbol context
         (lambda (context*)
+	  (*print-char #\space context*)
 	  (*print-string (symbol->string symbol) context*)))))
 
 (define (print-symbol symbol context)
@@ -602,7 +634,7 @@ USA.
 			      (begin
 				(*print-char #\space context*)
 				(print-object (safe-vector-ref vector index)
-						 context*)
+					      context*)
 				(loop (fix:+ index 1))))))
 		    (*print-char #\) context*))
 		  (*print-string "#()" context*))))))))
@@ -632,7 +664,7 @@ USA.
 			(begin
 			  (*print-char #\space context*)
 			  (print-number (bytevector-u8-ref bytevector index)
-					 context*)
+					context*)
 			  (loop (fix:+ index 1))))))
 	      (*print-char #\) context*))
 	    (*print-string "#u8()" context*))))))
@@ -755,6 +787,7 @@ USA.
 	     required optional rest body
 	     (and (not (eq? name scode-lambda-name:unnamed))
 		  (lambda (context*)
+		    (*print-char #\space context*)
 		    (print-object name context*))))))))
 
 (define (print-primitive-procedure procedure context)
@@ -766,7 +799,10 @@ USA.
 	  ((get-param:print-with-maximum-readability?)
 	   (*print-readable-hash procedure context))
 	  (else
-	   (*print-with-brackets 'primitive-procedure #f context print-name)))))
+	   (*print-with-brackets 'primitive-procedure #f context
+	     (lambda (context*)
+	       (*print-char #\space context*)
+	       (print-name context*)))))))
 
 (define (print-compiled-entry entry context)
   (let* ((type (compiled-entry-type entry))
@@ -782,6 +818,7 @@ USA.
 	(let ((name (and procedure? (compiled-procedure/name entry))))
 	  (receive (filename block-number)
 	      (compiled-entry/filename-and-index entry)
+	    (*print-char #\space context*)
 	    (*print-char #\( context*)
 	    (if name
 		(*print-string name context*))
@@ -810,26 +847,31 @@ USA.
 (define (print-return-address return-address context)
   (*print-with-brackets 'return-address return-address context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (return-address/name return-address) context*))))
 
 (define (print-assignment assignment context)
   (*print-with-brackets 'assignment assignment context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-assignment-name assignment) context*))))
 
 (define (print-definition definition context)
   (*print-with-brackets 'definition definition context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-definition-name definition) context*))))
 
 (define (print-lambda lambda-object context)
   (*print-with-brackets 'lambda lambda-object context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-lambda-name lambda-object) context*))))
 
 (define (print-variable variable context)
   (*print-with-brackets 'variable variable context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (scode-variable-name variable) context*))))
 
 (define (print-number object context)
@@ -866,7 +908,8 @@ USA.
 		      (if limit
 			  (min length limit)
 			  length))))
-               (print-flonum ((ucode-primitive floating-vector-ref) v 0)
+               (*print-char #\space context*)
+	       (print-flonum ((ucode-primitive floating-vector-ref) v 0)
 			       context*)
                (do ((i 1 (+ i 1)))
                    ((>= i limit))
@@ -884,7 +927,8 @@ USA.
   (define (named-arity-dispatched-procedure name)
     (*print-with-brackets 'arity-dispatched-procedure entity context
       (lambda (context*)
-        (*print-string name context*))))
+        (*print-char #\space context*)
+	(*print-string name context*))))
 
   (cond ((continuation? entity)
          (plain 'continuation))
@@ -905,10 +949,10 @@ USA.
   (*print-with-brackets 'promise promise context
     (if (promise-forced? promise)
 	(lambda (context*)
-	  (*print-string "(evaluated) " context*)
+	  (*print-string " (evaluated) " context*)
 	  (print-object (promise-value promise) context*))
 	(lambda (context*)
-	  (*print-string "(unevaluated)" context*)
+	  (*print-string " (unevaluated)" context*)
 	  (if (get-param:print-with-datum?)
 	      (begin
 		(*print-char #\space context*)
@@ -917,10 +961,11 @@ USA.
 (define (print-tagged-object object context)
   (*print-with-brackets 'tagged-object object context
     (lambda (context*)
+      (*print-char #\space context*)
       (print-object (let ((tag (%tagged-object-tag object)))
 		       (if (dispatch-tag? tag)
 			   (dispatch-tag-name tag)
 			   tag))
 		     context*)
-      (*print-string " " context*)
-      (print-object (%tagged-object-datum object) context*))))
\ No newline at end of file
+      (*print-char #\space context*)
+      (print-object (%tagged-object-datum object) context*))))
diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm
index 43f46e5fa..24a2301e3 100644
--- a/src/runtime/prop1d.scm
+++ b/src/runtime/prop1d.scm
@@ -35,7 +35,7 @@ USA.
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! 1d-table-tag
-				    (standard-unparser-method '1d-table #f)))
+				    (standard-print-method '1d-table)))
 
 (define population-of-1d-tables)
 
diff --git a/src/runtime/random.scm b/src/runtime/random.scm
index e5f1f3e67..53eaa71be 100644
--- a/src/runtime/random.scm
+++ b/src/runtime/random.scm
@@ -416,6 +416,6 @@ USA.
 				'#(index borrow vector)
 				'#(1 2 3)
 				(make-vector 3 (lambda () #f))
-				(standard-unparser-method 'random-state #f)
+				(standard-print-method 'random-state)
 				random-state-tag
 				4)))
\ No newline at end of file
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 78bc70922..537a00388 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -113,7 +113,7 @@ USA.
 	   #f)))
     (if (and unparser-method
 	     (not (default-object? unparser-method)))
-	(define-unparser-method (record-predicate type) unparser-method))
+	(define-print-method (record-predicate type) unparser-method))
     type))
 
 (define (list-of-unique-symbols? object)
@@ -543,20 +543,19 @@ USA.
 
 ;;;; Printing
 
-(define-unparser-method %record?
-  (standard-unparser-method '%record #f))
+(define-print-method %record?
+  (standard-print-method '%record))
 
-(define-unparser-method record?
-  (standard-unparser-method
+(define-print-method record?
+  (standard-print-method
    (lambda (record)
      (strip-angle-brackets
-      (dispatch-tag-name (record-type-descriptor record))))
-   #f))
+      (dispatch-tag-name (record-type-descriptor record))))))
 
 (add-boot-init!
  (lambda ()
-   (define-unparser-method record-type?
-     (simple-unparser-method 'record-type
+   (define-print-method record-type?
+     (standard-print-method 'record-type
        (lambda (type)
 	 (list (dispatch-tag-name type)))))))
 
@@ -578,7 +577,7 @@ USA.
 
 ;;; For backwards compatibility:
 (define (set-record-type-unparser-method! record-type method)
-  (define-unparser-method (record-predicate record-type)
+  (define-print-method (record-predicate record-type)
     method))
 
 ;;;; Runtime support for DEFINE-STRUCTURE
@@ -596,7 +595,7 @@ USA.
 (define structure-type/length)
 (add-boot-init!
  (lambda ()
-   ;; unparser-method arg should be removed after 9.3 is released.
+   ;; unparser-method field should be removed after 9.3 is released.
    (set! rtd:structure-type
 	 (make-record-type "structure-type"
 			   '(physical-type name field-names field-indexes
diff --git a/src/runtime/reference-trap.scm b/src/runtime/reference-trap.scm
index b830ef75a..a34527e86 100644
--- a/src/runtime/reference-trap.scm
+++ b/src/runtime/reference-trap.scm
@@ -33,7 +33,7 @@ USA.
 		   (type vector)
 		   (named '|#[(runtime reference-trap)reference-trap]|)
 		   (print-procedure
-		    (simple-unparser-method 'reference-trap
+		    (standard-print-method 'reference-trap
 		      (lambda (trap)
 			(list (let ((kind (reference-trap-kind trap)))
 				 (or (reference-trap-kind-name kind)
diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm
index f37f4ed02..1192fac82 100644
--- a/src/runtime/rfc2822-headers.scm
+++ b/src/runtime/rfc2822-headers.scm
@@ -42,8 +42,8 @@ USA.
 
 (define-guarantee rfc2822-header "RFC 2822 header field")
 
-(define-unparser-method rfc2822-header?
-  (simple-unparser-method 'rfc2822-header
+(define-print-method rfc2822-header?
+  (standard-print-method 'rfc2822-header
     (lambda (header)
       (list (rfc2822-header-name header)))))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a2eb95de4..d4baa674f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -134,6 +134,10 @@ USA.
 (define-package (runtime boot-definitions)
   (files "boot")
   (parent (runtime))
+  (export () deprecated:boot-definitions
+	  (define-unparser-method define-print-method)
+	  (simple-unparser-method standard-print-method)
+	  (standard-unparser-method bracketed-print-method))
   (export ()
 	  %false->weak-false
 	  %make-record
@@ -151,16 +155,15 @@ USA.
 	  %weak-false->false
 	  %weak-false?
 	  %weak-set-car!
-	  bracketed-unparser-method
+	  bracketed-print-method
 	  bytes-per-object
 	  default-object
 	  default-object?
 	  define-pp-describer
-	  define-unparser-method
+	  define-print-method
 	  error:not-a
 	  error:not-a-list-of
 	  gc-space-status
-	  general-unparser-method
 	  guarantee
 	  guarantee-list-of
 	  interrupt-bit/after-gc
@@ -184,9 +187,7 @@ USA.
 	  set-dispatch-tag<=!
 	  set-predicate<=!
 	  simple-parser-method
-	  simple-unparser-method
-	  standard-unparser-method
-	  unparser-method?
+	  standard-print-method
 	  weak-car
 	  weak-cdr
 	  weak-cons
@@ -211,6 +212,10 @@ USA.
 	  %weak-car)
   (export (runtime predicate)
 	  set-predicate-tag!)
+  (export (runtime printer)
+	  standard-print-method-name
+	  standard-print-method-parts
+	  standard-print-method?)
   (export (runtime rep)
 	  finished-booting!)
   (export (runtime tagged-dispatch)
@@ -5784,4 +5789,4 @@ USA.
   (import (runtime save/restore)
 	  time-world-restored)
   (export ()
-	  world-report))
\ No newline at end of file
+	  world-report))
diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 60e8618e4..98422f8cf 100644
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -327,11 +327,10 @@ USA.
 (define top-level-mime-types
   '#(text image audio video application multipart message))
 
-(define-unparser-method mime-type?
-  (standard-unparser-method 'mime-type
-    (lambda (mime-type port)
-      (write-char #\space port)
-      (write-string (mime-type->string mime-type) port))))
+(define-print-method mime-type?
+  (standard-print-method 'mime-type
+    (lambda (mime-type)
+      (list (mime-type->string mime-type)))))
 
 (define interned-mime-types)
 (define unusual-interned-mime-types)
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 54ac0ab93..157086519 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -84,8 +84,8 @@ USA.
   (rename senv-rename)
   (describe senv-describe))
 
-(define-unparser-method syntactic-environment?
-  (simple-unparser-method 'syntactic-environment
+(define-print-method syntactic-environment?
+  (standard-print-method 'syntactic-environment
     (lambda (senv)
       (list ((senv-get-type senv))))))
 
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 72ad5548c..9ada1d148 100644
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -41,8 +41,8 @@ USA.
     var-item?
   (id var-item-id))
 
-(define-unparser-method var-item?
-  (simple-unparser-method 'var-item
+(define-print-method var-item?
+  (standard-print-method 'var-item
     (lambda (item)
       (list (var-item-id item)))))
 
@@ -83,8 +83,8 @@ USA.
   (value defn-item-value)
   (syntax? defn-item-syntax?))
 
-(define-unparser-method defn-item?
-  (simple-unparser-method 'defn-item
+(define-print-method defn-item?
+  (standard-print-method 'defn-item
     (lambda (item)
       (list (defn-item-id item)
 	    (defn-item-value item)))))
diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm
index e853b5123..7843e0bb8 100644
--- a/src/runtime/textual-port.scm
+++ b/src/runtime/textual-port.scm
@@ -60,8 +60,8 @@ USA.
   (flush-output port-type-operation:flush-output)
   (discretionary-flush-output port-type-operation:discretionary-flush-output))
 
-(define-unparser-method textual-port-type?
-  (standard-unparser-method
+(define-print-method textual-port-type?
+  (standard-print-method
    (lambda (type)
      (if (port-type-supports-input? type)
 	(if (port-type-supports-output? type)
@@ -69,8 +69,7 @@ USA.
 	    'textual-input-port-type)
 	(if (port-type-supports-output? type)
 	    'textual-output-port-type
-	    'textual-port-type)))
-   #f))
+	    'textual-port-type)))))
 
 (define (port-type-supports-input? type)
   (port-type-operation:read-char type))
@@ -416,8 +415,8 @@ USA.
 (register-predicate! textual-i/o-port? 'textual-i/o-port
 		     '<= textual-port?)
 
-(define-unparser-method textual-port?
-  (standard-unparser-method
+(define-print-method textual-port?
+  (bracketed-print-method
    (lambda (port)
      (cond ((textual-i/o-port? port) 'textual-i/o-port)
 	   ((textual-input-port? port) 'textual-input-port)
diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm
index 03e6f1130..5aeea23db 100644
--- a/src/runtime/thread-queue.scm
+++ b/src/runtime/thread-queue.scm
@@ -45,7 +45,7 @@ USA.
 (define-structure (thread-queue (constructor %make-thread-queue)
 				(conc-name %thread-queue/)
 				(print-procedure
-				 (standard-unparser-method
+				 (bracketed-print-method
 				  'thread-queue
 				  (lambda (queue port)
 				    (print-thread-queue queue port)))))
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 1f034636e..6f0297ca0 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -136,7 +136,7 @@ USA.
 				'#(waiting-threads owner)
 				'#(1 2)
 				(vector 2 (lambda () #f))
-				(standard-unparser-method 'thread-mutex #f)
+				(standard-print-method 'thread-mutex)
 				thread-mutex-tag
 				3))
   (named-structure/set-tag-description! link-tag
@@ -145,7 +145,7 @@ USA.
 				'#(prev next item)
 				'#(1 2 3)
 				(vector 3 (lambda () #f))
-				(standard-unparser-method 'link #f)
+				(standard-print-method 'link)
 				link-tag
 				4)))
 
diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index de9207574..34dfc08ae 100644
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -117,8 +117,8 @@ USA.
   (host uri-authority-host)
   (port uri-authority-port))
 
-(define-unparser-method uri-authority?
-  (simple-unparser-method 'uri-authority
+(define-print-method uri-authority?
+  (standard-print-method 'uri-authority
     (lambda (authority)
       (list (call-with-output-string
 	      (lambda (port)
@@ -953,8 +953,8 @@ USA.
   (fragment partial-uri-fragment set-partial-uri-fragment!)
   (extra partial-uri-extra set-partial-uri-extra!))
 
-(define-unparser-method partial-uri?
-  (standard-unparser-method 'partial-uri
+(define-print-method partial-uri?
+  (bracketed-print-method 'partial-uri
     (lambda (puri port)
       (write-char #\space port)
       (write-partial-uri puri port))))
diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm
index ebfd49269..5404946cc 100644
--- a/src/runtime/win32-registry.scm
+++ b/src/runtime/win32-registry.scm
@@ -139,7 +139,7 @@ USA.
 		   (constructor %make-registry-key (parent name handle))
 		   (predicate win32-registry/key?)
 		   (print-procedure
-		    (simple-unparser-method 'registry-key
+		    (standard-print-method 'registry-key
 		      (lambda (key)
 			(list (registry-key-name key))))))
   (name #f read-only #t)
@@ -163,7 +163,7 @@ USA.
 
 (define-structure (registry-value
 		   (print-procedure
-		    (simple-unparser-method 'registry-value
+		    (standard-print-method 'registry-value
 		      (lambda (key)
 			(list (registry-value-name key))))))
   (name #f read-only #t)
diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm
index 2e554011a..c6c6f4b95 100644
--- a/src/runtime/x11graph.scm
+++ b/src/runtime/x11graph.scm
@@ -223,7 +223,7 @@ USA.
 		   (conc-name x-display/)
 		   (constructor make-x-display (name xd))
 		   (print-procedure
-		    (simple-unparser-method 'x-display
+		    (standard-print-method 'x-display
 		      (lambda (display)
 			(list (x-display/name display))))))
   (name #f read-only #t)
diff --git a/src/sf/object.scm b/src/sf/object.scm
index ef6129bfc..a60c5323e 100644
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -190,7 +190,7 @@ USA.
                    (conc-name variable/)
                    (constructor variable/make (block name flags))
                    (print-procedure
-                    (simple-unparser-method 'variable
+                    (standard-print-method 'variable
 		      (lambda (var)
 			(list (variable/name var))))))
   block
@@ -606,7 +606,7 @@ USA.
                    (conc-name reference/)
                    (constructor reference/make)
                    (print-procedure
-                    (simple-unparser-method 'reference
+                    (standard-print-method 'reference
 		      (lambda (ref)
 			(list (variable/name (reference/variable ref)))))))
   (scode #f read-only #t)
diff --git a/src/sf/pthmap.scm b/src/sf/pthmap.scm
index ececfdd0b..15aa9e15c 100644
--- a/src/sf/pthmap.scm
+++ b/src/sf/pthmap.scm
@@ -41,7 +41,7 @@ USA.
 
 (unparser/set-tagged-pair-method!
  pathname-map/tag
- (standard-unparser-method "PATHNAME-MAP" #f))
+ (standard-print-method "PATHNAME-MAP"))
 
 (declare (integrate-operator node/make))
 
diff --git a/src/sos/class.scm b/src/sos/class.scm
index 76cbd1179..74ca40f8c 100644
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -33,7 +33,7 @@ USA.
 			 (constructor %make-class
 				      (name direct-superclasses direct-slots))
 			 (print-procedure
-			  (simple-unparser-method 'CLASS
+			  (standard-print-method 'CLASS
 			    (lambda (class)
 			      (let ((name (class-name class)))
 				(if name
diff --git a/src/sos/printer.scm b/src/sos/printer.scm
index 07a01af14..ce6e6cc9c 100644
--- a/src/sos/printer.scm
+++ b/src/sos/printer.scm
@@ -92,8 +92,8 @@ USA.
       (thunk))
   (write-char #\] port))
 
-(define-unparser-method instance?
-  (general-unparser-method write-instance))
+(define-print-method instance?
+  write-instance)
 
 (define (instance-description instance)
   (map (lambda (slot)
diff --git a/src/win32/module.scm b/src/win32/module.scm
index ec93601d9..275055d07 100644
--- a/src/win32/module.scm
+++ b/src/win32/module.scm
@@ -44,7 +44,7 @@ USA.
     (conc-name module/)
     (constructor %make-module)
     (print-procedure
-     (simple-unparser-method 'MODULE
+     (standard-print-method 'MODULE
        (lambda (module)
 	 (list (module/load-name module))))))
   load-name
diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm
index 69c574501..ba6e29975 100644
--- a/src/x11/x11-device.scm
+++ b/src/x11/x11-device.scm
@@ -127,7 +127,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		   (conc-name x-display/)
 		   (constructor make-x-display (name xd))
 		   (print-procedure
-		    (simple-unparser-method 'X-DISPLAY
+		    (standard-print-method 'X-DISPLAY
 		      (lambda (display)
 			(list (x-display/name display))))))
   (name #f read-only #t)
diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index a5a5b3958..a4bea2ce3 100644
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -151,11 +151,10 @@ USA.
 
 (define-guarantee rdf-bnode "RDF bnode")
 
-(define-unparser-method rdf-bnode?
-  (standard-unparser-method 'RDF-BNODE
-    (lambda (bnode port)
-      (write-char #\space port)
-      (write-string (rdf-bnode-name bnode) port))))
+(define-print-method rdf-bnode?
+  (standard-print-method 'rdf-bnode
+    (lambda (bnode)
+      (list (rdf-bnode-name bnode)))))
 
 (define (make-rdf-bnode #!optional name)
   (if (default-object? name)
@@ -225,8 +224,8 @@ USA.
     (and (not (absolute-uri? type))
 	 type)))
 
-(define-unparser-method rdf-literal?
-  (standard-unparser-method 'RDF-LITERAL
+(define-print-method rdf-literal?
+  (bracketed-print-method 'RDF-LITERAL
     (lambda (literal port)
       (write-char #\space port)
       (write-rdf/nt-literal literal port))))
diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index af5df75c6..b6f80f6e3 100644
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -89,8 +89,8 @@ USA.
   (qname combo-name-qname)
   (expanded combo-name-expanded))
 
-(define-unparser-method combo-name?
-  (simple-unparser-method 'XML-NAME
+(define-print-method combo-name?
+  (standard-print-method 'XML-NAME
     (lambda (name)
       (list (combo-name-qname name)))))
 
diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index 0512be470..33004b11f 100644
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -90,8 +90,8 @@ USA.
   (indent-attributes? ctx-indent-attributes?)
   (indent-dtd? ctx-indent-dtd?))
 
-(define-unparser-method ctx?
-  (standard-unparser-method 'xml-output-context #f))
+(define-print-method ctx?
+  (standard-print-method 'xml-output-context))
 
 (define (emit-char char ctx)
   (let ((port (ctx-port ctx)))
diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index de1654a34..2321bca8c 100644
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -427,9 +427,9 @@ USA.
 	 (let ((name (cadr form))
 	       (accessor (caddr form)))
 	   (let ((root (symbol 'XML- name)))
-	     `(define-unparser-method
+	     `(define-print-method
 	       ,(close-syntax (symbol root '?) environment)
-	       (SIMPLE-UNPARSER-METHOD ',root
+	       (standard-print-method ',root
 		 (LAMBDA (,name)
 		   (LIST (,(close-syntax accessor environment) ,name)))))))
 	 (ill-formed-syntax form)))))