From 6d5564770717123309ab03fe207f658f19bc9a69 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 17 Aug 2007 16:19:31 +0000
Subject: [PATCH] checkpoint new GUI toolbox docs

svn: r7109

original commit: c7c3d60b1666fcd4b1dba547bb7c64e7d61447ac
---
 collects/scribble/html-render.ss | 10 +++++++++
 collects/scribble/manual.ss      | 36 ++++++++++++++++++++++----------
 2 files changed, 35 insertions(+), 11 deletions(-)

diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index f9783ba4..0aad6228 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -314,6 +314,16 @@
               [else (error 'html-render "unrecognized style symbol: ~e" style)])]
            [(string? style) 
             `((span ([class ,style]) ,@(super render-element e part ht)))]
+           [(and (pair? style)
+                 (eq? (car style) 'show-color))
+            `((font ((style ,(format "background-color: ~a"
+                                    (apply string-append "#"
+                                           (map (lambda (v) (let ([s (format "0~x" v)])
+                                                              (substring s (- (string-length s) 2))))
+                                                (cdr style))))))
+                    (tt nbsp nbsp nbsp nbsp nbsp))
+              nbsp
+              ,@(super render-element e part ht))]
            [(target-url? style)
             (if (current-no-links)
                 (super render-element e part ht)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
index 076bb0e3..7a543152 100644
--- a/collects/scribble/manual.ss
+++ b/collects/scribble/manual.ss
@@ -480,6 +480,20 @@
 
   (define max-proto-width 65)
 
+  (define (name-this-object type-sym)
+    (to-element
+     (string->symbol
+      (regexp-replace
+       #rx"(%|<%>|-mixin)$"
+       (format "_a~a-~s" 
+               (if (member
+                    (string-ref (symbol->string type-sym) 0)
+                    '(#\a #\e #\i #\o #\u))
+                   "n"
+                   "")
+               type-sym)
+       ""))))
+
   (define (*defproc mode within-id
                     stx-ids prototypes arg-contractss result-contracts content-thunk)
     (let ([spacer (hspace 1)]
@@ -564,17 +578,7 @@
                                          (make-element #f
                                                        (list (scheme send)
                                                              (hspace 1)
-                                                             (to-element (string->symbol
-                                                                          (regexp-replace
-                                                                           #rx"(%|<%>|-mixin)$"
-                                                                           (format "a~a-~s" 
-                                                                                   (if (member
-                                                                                        (string-ref (symbol->string (syntax-e within-id)) 0)
-                                                                                        '(#\a #\e #\i #\o #\u))
-                                                                                       "n"
-                                                                                       "")
-                                                                                   (syntax-e within-id))
-                                                                           "")))
+                                                             (name-this-object (syntax-e within-id))
                                                              (hspace 1)
                                                              (if first?
                                                                  (let* ([mname (car prototype)]
@@ -1225,6 +1229,7 @@
            defmethod*
            methspec
            methimpl
+           this-obj
            include-class)
 
   (define-syntax-parameter current-class #f)
@@ -1417,5 +1422,14 @@
     (syntax-rules ()
       [(_ body ...) (make-spec (lambda () (list (italic "Specification:") body ...)))]))
 
+  (define (*this-obj cname)
+    (name-this-object cname))
+
+  (define-syntax (this-obj stx)
+    (syntax-case stx ()
+      [(_) 
+       (with-syntax ([cname (syntax-parameter-value #'current-class)])
+         #'(*this-obj 'cname))]))
+
   ;; ----------------------------------------
   )