Eliminate use of record-specific printing registration.

diff --git a/src/edwin/edtstr.scm b/src/edwin/edtstr.scm
index cfed6ea23647f4fbc1dd383da83e483168ea0af7..58a8c645832cdd91a19ff987ab350ba32ab4fdd4 100644 (file)
--- a/src/edwin/edtstr.scm
+++ b/src/edwin/edtstr.scm
@@ -129,7 +129,7 @@ USA.
 (define (button-name button)
   (symbol->string (button-symbol button)))
 
-(set-record-type-unparser-method! <button>
+(define-unparser-method button?
   (simple-unparser-method (record-type-name <button>)
     (lambda (button)
       (list (button-symbol button)))))

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 223bc907f9f5851563facd3983749bec7a898255..f11aefde13878a8cd93f5648093cb373536981cb 100644 (file)
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -85,13 +85,13 @@ USA.
                        '<= binary-input-port?
                        '<= binary-output-port?)))
 
-(set-record-type-unparser-method! <binary-port>
+(define-unparser-method binary-port?
   (standard-unparser-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)))
+     (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))
 \f
 ;;;; Bytevector input ports

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index aac9d3e753bcf5104e2167e8919f21e622c8f26b..47bbdb8d7958497c50a72300c9c944dc848cd970 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -186,7 +186,7 @@ USA.
 (define (define-bundle-printer interface printer)
   (hash-table-set! bundle-printers interface printer))
 
-(set-record-type-entity-unparser-method! <bundle-metadata>
+(define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
      (bundle-interface-name (bundle-interface bundle)))
@@ -198,7 +198,7 @@ USA.
        (if printer
           (printer bundle port))))))
 
-(set-record-type-entity-describer! <bundle-metadata>
+(define-pp-describer bundle?
   (lambda (bundle)
     (map (lambda (name)
           (list name (bundle-ref bundle name)))

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 4bfd691dc554c102358c9bf4ce6f5d2b53122654..39fc9901ea676532682a8adf0efad9fe0f25e9d7 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -45,7 +45,7 @@ USA.
 ;; two digits representing a larger number, then RADIX is their base.
 (define %radix)
 
-(set-record-type-unparser-method! rtd:alien
+(define-unparser-method alien?
   (standard-unparser-method
    'alien
    (lambda (alien port)

diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm
index c8b8d70d9666b3168e9383147853b358b50916dd..f01baefe9a4f1fb142e6af01f7d1f8bee4dac304 100644 (file)
--- a/src/runtime/http-syntax.scm
+++ b/src/runtime/http-syntax.scm
@@ -234,7 +234,7 @@ USA.
 
 (define-guarantee http-header "HTTP header field")
 
-(set-record-type-unparser-method! <http-header>
+(define-unparser-method http-header?
   (simple-unparser-method 'HTTP-HEADER
     (lambda (header)
       (list (http-header-name header)))))

diff --git a/src/runtime/httpio.scm b/src/runtime/httpio.scm
index e4caf4b0b0933d4bd27119af671024ba723957b9..5304dc98dc2059540b95ed93466fcd73216c7730 100644 (file)
--- a/src/runtime/httpio.scm
+++ b/src/runtime/httpio.scm
@@ -49,7 +49,7 @@ USA.
       (guarantee-headers&body headers body 'MAKE-HTTP-REQUEST)
     (%make-http-request method uri version headers body)))
 
-(set-record-type-unparser-method! <http-request>
+(define-unparser-method http-request?
   (simple-unparser-method 'HTTP-REQUEST
     (lambda (request)
       (list (http-request-method request)
@@ -72,7 +72,7 @@ USA.
       (guarantee-headers&body headers body 'MAKE-HTTP-RESPONSE)
     (%make-http-response version status reason headers body)))
 
-(set-record-type-unparser-method! <http-response>
+(define-unparser-method http-response?
   (simple-unparser-method 'HTTP-RESPONSE
     (lambda (response)
       (list (http-response-status response)))))

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index b155dc85dc5b337a060f3e5a1ab3c8a2f7f314b0..5b68da592ed6d36112bef47429fa32fa30234ff6 100644 (file)
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -74,8 +74,8 @@ USA.
     (let ((tag (record-type-dispatch-tag rtd)))
       (set! package-tag tag)
       (for-each (lambda (p) (%record-set! p 0 tag)) *packages*))
-    (set-record-type-unparser-method! rtd
-      (simple-unparser-method 'PACKAGE
+    (define-unparser-method (record-predicate rtd)
+      (simple-unparser-method 'package
        (lambda (package)
          (list (package/name package)))))))
 \f

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 4e1e527c79ef1692db54a148a09a8c6bb088132f..631f68299240d8959b10e709fa8d1888fa4f5c5e 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -60,7 +60,7 @@ USA.
   (flush-output port-type-operation:flush-output)
   (discretionary-flush-output port-type-operation:discretionary-flush-output))
 
-(set-record-type-unparser-method! <textual-port-type>
+(define-unparser-method textual-port-type?
   (standard-unparser-method
    (lambda (type)
      (if (port-type-supports-input? type)
@@ -422,7 +422,7 @@ USA.
    (register-predicate! textual-i/o-port? 'textual-i/o-port
                        '<= textual-port?)))
 
-(set-record-type-unparser-method! <textual-port>
+(define-unparser-method textual-port?
   (standard-unparser-method
    (lambda (port)
      (cond ((textual-i/o-port? port) 'TEXTUAL-I/O-PORT)

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 9c59983ce40144bc3dc3a5a8a9f56864155c707d..0c2d0a8b458da622f4f95168fb76ab70842ce2c4 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -534,23 +534,10 @@ USA.
               ,((record-accessor type field-name) record)))
           (record-type-field-names type)))))
 
-;;; These are for backwards compatibility:
-
+;;; For backwards compatibility:
 (define (set-record-type-unparser-method! record-type method)
   (define-unparser-method (record-predicate record-type)
     method))
-
-(define (set-record-type-describer! record-type describer)
-  (define-pp-describer (record-predicate record-type)
-    describer))
-
-(define (set-record-type-entity-unparser-method! record-type method)
-  (define-unparser-method (record-entity-predicate record-type)
-    method))
-
-(define (set-record-type-entity-describer! record-type describer)
-  (define-pp-describer (record-entity-predicate record-type)
-    describer))
 \f
 ;;;; Runtime support for DEFINE-STRUCTURE
 

diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm
index 9d6dbbbe4ece5b22bfd6126719855d87c37206fa..fc5e889bbedef361e1919006cb896512e2c8f919 100644 (file)
--- a/src/runtime/rfc2822-headers.scm
+++ b/src/runtime/rfc2822-headers.scm
@@ -42,7 +42,7 @@ USA.
 
 (define-guarantee rfc2822-header "RFC 2822 header field")
 
-(set-record-type-unparser-method! <rfc2822-header>
+(define-unparser-method rfc2822-header?
   (simple-unparser-method 'rfc2822-header
     (lambda (header)
       (list (rfc2822-header-name header)))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 78471db90e0945bc62fcd186bcd6ad4ccec7827d..f3ced32ab201e67198f13c26029fd71a6ae492c0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3723,6 +3723,8 @@ USA.
 (define-package (runtime record)
   (files "record")
   (parent (runtime))
+  (export () deprecated:record
+         set-record-type-unparser-method!)
   (export ()
          %copy-record
          %make-record
@@ -3766,11 +3768,7 @@ USA.
          record-type-name
          record-type?
          record-updater
-         record?
-         set-record-type-describer!
-         set-record-type-entity-describer!
-         set-record-type-entity-unparser-method!
-         set-record-type-unparser-method!)
+         record?)
   (export (runtime)
          error:no-such-slot
          error:uninitialized-slot

diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 0bca2af51b750e62dfcab38d2ac6059175d8c1f1..fe363867bdb6bdcbcefff890c23aa7e1ffb92eb3 100644 (file)
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -327,7 +327,7 @@ USA.
 (define top-level-mime-types
   '#(TEXT IMAGE AUDIO VIDEO APPLICATION MULTIPART MESSAGE))
 
-(set-record-type-unparser-method! <mime-type>
+(define-unparser-method mime-type?
   (standard-unparser-method 'MIME-TYPE
     (lambda (mime-type port)
       (write-char #\space port)

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index e7ad9d4b57d11d8ace57f982a5affadc0bf65c6c..408b5bfb004758d35dcc5ef648609cfd045a4b17 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -115,8 +115,8 @@ USA.
   (host uri-authority-host)
   (port uri-authority-port))
 
-(set-record-type-unparser-method! <uri-authority>
-  (simple-unparser-method 'URI-AUTHORITY
+(define-unparser-method uri-authority?
+  (simple-unparser-method 'uri-authority
     (lambda (authority)
       (list (call-with-output-string
              (lambda (port)
@@ -952,7 +952,7 @@ USA.
   (fragment partial-uri-fragment set-partial-uri-fragment!)
   (extra partial-uri-extra set-partial-uri-extra!))
 
-(set-record-type-unparser-method! <partial-uri>
+(define-unparser-method partial-uri?
   (standard-unparser-method 'PARTIAL-URI
     (lambda (puri port)
       (write-char #\space port)

diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index c8d9c686b14ee117dc538d28e94e0dc368b60ccc..e691d367c64c46b62160667a3ba19e4a5fd07c9e 100644 (file)
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -151,7 +151,7 @@ USA.
 
 (define-guarantee rdf-bnode "RDF bnode")
 
-(set-record-type-unparser-method! <rdf-bnode>
+(define-unparser-method rdf-bnode?
   (standard-unparser-method 'RDF-BNODE
     (lambda (bnode port)
       (write-char #\space port)
@@ -225,7 +225,7 @@ USA.
     (and (not (absolute-uri? type))
         type)))
 
-(set-record-type-unparser-method! <rdf-literal>
+(define-unparser-method rdf-literal?
   (standard-unparser-method 'RDF-LITERAL
     (lambda (literal port)
       (write-char #\space port)

diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index 72de482815d706d21b3ac22e70d6fc0b41083833..732b365c20d27de67f3113abb95aac70c513b087 100644 (file)
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -89,7 +89,7 @@ USA.
   (qname combo-name-qname)
   (expanded combo-name-expanded))
 
-(set-record-type-unparser-method! <combo-name>
+(define-unparser-method combo-name?
   (simple-unparser-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 5075a705fea7e70def86e201909dc376753090d6..1a5abe3efd3b2d63d8b9182767b5aecb8cb92918 100644 (file)
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -90,7 +90,7 @@ USA.
   (indent-attributes? ctx-indent-attributes?)
   (indent-dtd? ctx-indent-dtd?))
 
-(set-record-type-unparser-method! <ctx>
+(define-unparser-method ctx?
   (standard-unparser-method 'xml-output-context #f))
 
 (define (emit-char char ctx)

diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index 92851f8bd59d62e0fd7297c004e8a660b3fcfa29..b66cd95fb6ba93b3fc8ce316dda55348f3f46879 100644 (file)
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -427,8 +427,8 @@ USA.
         (let ((name (cadr form))
               (accessor (caddr form)))
           (let ((root (symbol 'XML- name)))
-            `(SET-RECORD-TYPE-UNPARSER-METHOD!
-              ,(close-syntax (symbol '< root '>) environment)
+            `(define-unparser-method
+              ,(close-syntax (symbol root '?) environment)
               (SIMPLE-UNPARSER-METHOD ',root
                 (LAMBDA (,name)
                   (LIST (,(close-syntax accessor environment) ,name)))))))