Change tagged-object to be tagged with a predicate.

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 67cd24b2e82c24e6c50d903d35afd050d94c1d28..ff466d02fbd23406ff7b87330ba7192833b9b2ff 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -449,9 +449,9 @@ USA.
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
-   ((RUNTIME TAGGING) INITIALIZE-UNPARSER!)
    (RUNTIME PREDICATE-METADATA)
    (RUNTIME PREDICATE-LATTICE)
+   (RUNTIME TAGGING)
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f602bf218181fe91b66ad2d7ee58fd7f5b484225..467152d5a3364829b054ad476f98783b91663049 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3597,14 +3597,16 @@ USA.
   (parent (runtime))
   (export ()
          guarantee-tagged-object
-         make-tagged-object
          set-tagged-object-unparser-method!
+         tag-object
          tagged-object-datum
-         tagged-object-tag
+         tagged-object-predicate
          tagged-object?)
+  (export (runtime)
+         tagged-object-tag)
   (export (runtime unparser)
          get-tagged-object-unparser-method)
-  (initialization (initialize-unparser!)))
+  (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
   (files "urtrap")

diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index 868b181a18fdb15d71feea121a4850819de4a54b..5cd0a05ab6f2e0c5349308ad1bcec73e10fe9b55 100644 (file)
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -35,21 +35,23 @@ USA.
 (define (tagged-object? object)
   (fix:= (object-type object) tagged-object-type))
 
-(define-guarantee tagged-object "tagged object")
+(define (tag-object predicate datum)
+  (system-pair-cons tagged-object-type (predicate->tag predicate) datum))
 
-(define (make-tagged-object tag datum)
-  (system-pair-cons tagged-object-type tag datum))
+(define (tagged-object-predicate object)
+  (tag->predicate (tagged-object-tag object)))
 
 (define (tagged-object-tag object)
-  (guarantee-tagged-object object 'tagged-object-tag)
+  (guarantee tagged-object? object 'tagged-object-tag)
   (system-pair-car object))
 
 (define (tagged-object-datum object)
-  (guarantee-tagged-object object 'tagged-object-datum)
+  (guarantee tagged-object? object 'tagged-object-datum)
   (system-pair-cdr object))
 
 (define unparser-methods)
-(define (initialize-unparser!)
+(define (initialize-package!)
+  (register-predicate! tagged-object? 'tagged-object)
   (set! unparser-methods (make-key-weak-eqv-hash-table))
   unspecific)