From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Jan 2018 20:19:42 +0000 (-0500)
Subject: Reimplement bundle printers to be more like other printers.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~422
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8de6f83b10097be8cdc30a67c9ebc6c4cef9cc3b;p=mit-scheme.git

Reimplement bundle printers to be more like other printers.
---

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 6f4ebf33e..c1fd3229d 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -131,15 +131,18 @@ USA.
   (tag bundle-metadata-tag)
   (alist bundle-metadata-alist))
 
+(define (define-bundle-printer interface printer)
+  (hash-table-set! bundle-printers (predicate->tag interface) printer))
+
 (set-record-type-entity-unparser-method! <bundle-metadata>
-  (bracketed-unparser-method
+  (standard-unparser-method
+   (lambda (bundle)
+     (bim-name (tag-extra (bundle-tag bundle))))
    (lambda (bundle port)
-     (write (bim-name (tag-extra (bundle-tag bundle))) port)
-     (write-string " " port)
-     (write (object-hash bundle) port)
-     (let ((handler (bundle-ref bundle 'write-self #f)))
-       (if handler
-	   (handler port))))))
+     (let ((printer
+	    (hash-table-ref/default bundle-printers (bundle-tag bundle) #f)))
+       (if printer
+	   (printer bundle port))))))
 
 (define (bundle? object)
   (and (entity? object)
@@ -170,9 +173,11 @@ USA.
           default))))
 
 (define the-bundle-tag)
+(define bundle-printers)
 (add-boot-init!
  (lambda ()
    (register-predicate! bundle? 'bundle '<= entity?)
    (set! the-bundle-tag (predicate->tag bundle?))
+   (set! bundle-printers (make-key-weak-eqv-hash-table))
    (register-predicate! bundle-interface? 'bundle-interface '<= predicate?)
    (register-predicate! clauses? 'interface-clauses)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b24fde256..e2e36ff39 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1950,6 +1950,7 @@ USA.
 	  bundle-names
 	  bundle-ref
 	  bundle?
+	  define-bundle-printer
 	  make-bundle
 	  make-bundle-interface))