*mplement object-tagger.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 467152d5a3364829b054ad476f98783b91663049..9d4f4b4a1639e13d4e934c8dba7ece81b67215f0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3597,6 +3597,7 @@ USA.
   (parent (runtime))
   (export ()
          guarantee-tagged-object
+         object-tagger
          set-tagged-object-unparser-method!
          tag-object
          tagged-object-datum

diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index 7efcd7bd1ddf1cc63ef89c930a903f55616a0920..fec5f84dac4a948e62f04a5e5e98a8769f5d2893 100644 (file)
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -35,12 +35,20 @@ USA.
 (define (tagged-object? object)
   (fix:= (object-type object) tagged-object-type))
 
+(define (object-tagger predicate)
+  (let ((tag (predicate->tag predicate)))
+    (lambda (datum)
+      (make-tagged-object tag datum))))
+
 (define (tag-object predicate datum)
-  (system-pair-cons tagged-object-type (predicate->tag predicate) datum))
+  (make-tagged-object (predicate->tag predicate) datum))
 
 (define (tagged-object-predicate object)
   (tag->predicate (tagged-object-tag object)))
 
+(define-integrable (make-tagged-object tag datum)
+  (system-pair-cons tagged-object-type tag datum))
+
 (define (tagged-object-tag object)
   (guarantee tagged-object? object 'tagged-object-tag)
   (system-pair-car object))