diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss
new file mode 100644
index 00000000..81906dad
--- /dev/null
+++ b/collects/framework/private/color-prefs.ss
@@ -0,0 +1,245 @@
+(module color-prefs mzscheme
+  (require (lib "class.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           "sig.ss")
+           
+  
+  (provide color-prefs@)
+  
+  (define color-prefs@
+    (unit/sig framework:color-prefs^
+      (import [preferences : framework:preferences^]
+              [editor : framework:editor^])
+      
+      (define standard-style-list-text% (editor:standard-style-list-mixin text%))
+
+      (define color-selection%
+        (class horizontal-panel%
+          (init symbol prefix)
+          (super-instantiate () (style '(border)))
+          
+          (define sym (string->symbol (format "~a:~a" prefix symbol)))
+          
+          (define delta (preferences:get sym))
+          (define style-name (symbol->string sym))
+          (define c (make-object editor-canvas% this
+                      #f
+                      (list 'hide-hscroll
+                            'hide-vscroll)))
+          (send c set-line-count 1)
+          (send c allow-tab-exit #t)
+          (define e (new (class standard-style-list-text%
+                           (inherit change-style get-style-list)
+                           (rename [super-after-insert after-insert])
+                           (override after-insert)
+                           (define (after-insert pos offset)
+                             (super-after-insert pos offset)
+                             (let ([style (send (get-style-list)
+                                                find-named-style
+                                                style-name)])
+                               (change-style style pos (+ pos offset) #f)))
+                           (super-instantiate ()))))
+          (preferences:add-callback sym
+                                    (lambda (sym v)
+                                      (set-slatex-style sym v)
+                                      #t))
+          (set-slatex-style sym delta)
+          (define (make-check name on off)
+            (let* ([c (lambda (check command)
+                        (if (send check get-value)
+                            (on)
+                            (off))
+                        (preferences:set sym delta))]
+                   [check (make-object check-box% name this c)])
+              check))
+          (send c set-editor e)
+          (send* e
+            (insert (symbol->string symbol))
+            (set-position 0))
+          (define slant-check
+            (make-check (string-constant cs-italic)
+                        (lambda ()
+                          (send delta set-style-on 'slant)
+                          (send delta set-style-off 'base))
+                        (lambda ()
+                          (send delta set-style-on 'base)
+                          (send delta set-style-off 'slant))))
+          (define bold-check
+            (make-check (string-constant cs-bold)
+                        (lambda ()
+                          (send delta set-weight-on 'bold)
+                          (send delta set-weight-off 'base))
+                        (lambda ()
+                          (send delta set-weight-on 'base)
+                          (send delta set-weight-off 'bold))))
+          (define underline-check
+            (make-check (string-constant cs-underline)
+                        (lambda ()
+                          (send delta set-underlined-on #t)
+                          (send delta set-underlined-off #f))
+                        (lambda ()
+                          (send delta set-underlined-off #t)
+                          (send delta set-underlined-on #f))))
+          (define color-button
+            (and (>= (get-display-depth) 8)
+                 (make-object button%
+                   (string-constant cs-change-color)
+                   this
+                   (lambda (color-button evt)
+                     (let* ([add (send delta get-foreground-add)]
+                            [color (make-object color%
+                                     (send add get-r)
+                                     (send add get-g)
+                                     (send add get-b))]
+                            [users-choice
+                             (get-color-from-user
+                              (format "Choose a color for ~a"
+                                      (symbol->string symbol))
+                              (send color-button get-top-level-window)
+                              color)])
+                       (when users-choice
+                         (send delta set-delta-foreground users-choice)
+                         (preferences:set sym delta)))))))
+          (define style (send (send e get-style-list) find-named-style style-name))
+          (send slant-check set-value (eq? (send style get-style) 'slant))
+          (send bold-check set-value (eq? (send style get-weight) 'bold))
+          (send underline-check set-value (send style get-underlined))))
+      
+      (define add/mult-set
+        (lambda (m v)
+          (send m set (car v) (cadr v) (caddr v))))
+      
+      (define add/mult-get
+        (lambda (m)
+          (let ([b1 (box 0)]
+                [b2 (box 0)]
+                [b3 (box 0)])
+            (send m get b1 b2 b3)
+            (map unbox (list b1 b2 b3)))))
+      
+      (define style-delta-get/set
+        (list (cons (lambda (x) (send x get-alignment-off))
+                    (lambda (x v) (send x set-alignment-off v)))
+              (cons (lambda (x) (send x get-alignment-on))
+                    (lambda (x v) (send x set-alignment-on v)))
+              (cons (lambda (x) (add/mult-get (send x get-background-add)))
+                    (lambda (x v) (add/mult-set (send x get-background-add) v)))
+              (cons (lambda (x) (add/mult-get (send x get-background-mult)))
+                    (lambda (x v) (add/mult-set (send x get-background-mult) v)))
+              (cons (lambda (x) (send x get-face))
+                    (lambda (x v) (send x set-face v)))
+              (cons (lambda (x) (send x get-family))
+                    (lambda (x v) (send x set-family v)))
+              (cons (lambda (x) (add/mult-get (send x get-foreground-add)))
+                    (lambda (x v) (add/mult-set (send x get-foreground-add) v)))
+              (cons (lambda (x) (add/mult-get (send x get-foreground-mult)))
+                    (lambda (x v) (add/mult-set (send x get-foreground-mult) v)))
+              (cons (lambda (x) (send x get-size-add))
+                    (lambda (x v) (send x set-size-add v)))
+              (cons (lambda (x) (send x get-size-mult))
+                    (lambda (x v) (send x set-size-mult v)))
+              (cons (lambda (x) (send x get-style-off))
+                    (lambda (x v) (send x set-style-off v)))
+              (cons (lambda (x) (send x get-style-on))
+                    (lambda (x v) (send x set-style-on v)))
+              (cons (lambda (x) (send x get-underlined-off))
+                    (lambda (x v) (send x set-underlined-off v)))
+              (cons (lambda (x) (send x get-underlined-on))
+                    (lambda (x v) (send x set-underlined-on v)))
+              (cons (lambda (x) (send x get-weight-off))
+                    (lambda (x v) (send x set-weight-off v)))
+              (cons (lambda (x) (send x get-weight-on))
+                    (lambda (x v) (send x set-weight-on v)))))
+      
+      (define (marshall-style style)
+        (map (lambda (fs) ((car fs) style)) style-delta-get/set))
+      
+      (define (unmarshall-style info)
+        (let ([style (make-object style-delta%)])
+          (for-each (lambda (fs v) ((cdr fs) style v)) style-delta-get/set info)
+          style))
+      
+      (define (set-default sym code-style)
+        (preferences:set-default
+         sym
+         code-style
+         (lambda (x)
+           (is-a? x style-delta%)))
+        (preferences:set-un/marshall sym marshall-style unmarshall-style))
+      
+      
+      ; a symbol naming the style  and a delta to set it to
+      (define set-slatex-style
+        (lambda (sym delta)
+          (let* ([style-list (editor:get-standard-style-list)]
+                 [name (symbol->string sym)]
+                 [style (send style-list find-named-style name)])
+            (if style
+                (send style set-delta delta)
+                (send style-list new-named-style name
+                      (send style-list find-or-create-style
+                            (send style-list find-named-style "Standard")
+                            delta))))))
+      
+      
+      (define (make-style-delta color bold? underline? italic?)
+        (let ((sd (make-object style-delta%)))
+          (send sd set-delta-foreground color)
+          (cond
+            (bold?
+             (send sd set-weight-on 'bold)
+             (send sd set-weight-off 'base))
+            (else
+             (send sd set-weight-on 'base)
+             (send sd set-weight-off 'bold)))
+          (send sd set-underlined-on underline?)
+          (send sd set-underlined-off (not underline?))
+          (cond
+            (italic?
+             (send sd set-style-on 'italic)
+             (send sd set-style-off 'base))
+            (else
+             (send sd set-style-on 'base)
+             (send sd set-style-off 'italic)))
+          sd))
+      
+      
+      (define color-selection-panel%
+        (class vertical-panel%
+          (init symbols prefix)
+          
+          (super-instantiate ())
+          
+          (for-each
+           (lambda (s)
+             (new color-selection% (prefix prefix) (symbol s) (parent this)))
+           symbols)
+          ))
+      
+      
+      (define (add tab-name symbols/defaults)
+        (let* ((prefix (string->symbol (format "syntax-coloring:~a" tab-name)))
+               (active-pref (string->symbol (format "~a:active" prefix))))
+          (for-each (lambda (s)
+                      (set-default (string->symbol (format "~a:~a" prefix (car s)))
+                                   (cadr s)))
+                    symbols/defaults)
+          (preferences:set-default active-pref #t (lambda (x) #t))
+          (preferences:add-panel `("Editing" "Colors" ,tab-name)
+                                 (lambda (p)
+                                   (let ((vp (new vertical-panel% (parent p))))
+                                     (new color-selection-panel%
+                                          (parent vp)
+                                          (prefix prefix)
+                                          (symbols (map car symbols/defaults)))
+                                     (let ((cb (new check-box%
+                                                    (parent vp)
+                                                    (label "Activate Coloring?")
+                                                    (callback (lambda (checkbox y)
+                                                                (preferences:set 
+                                                                 active-pref
+                                                                 (send checkbox get-value)))))))
+                                       (send cb set-value (preferences:get active-pref)))
+                                     vp))))))))
diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss
new file mode 100644
index 00000000..c3304381
--- /dev/null
+++ b/collects/framework/private/color.ss
@@ -0,0 +1,440 @@
+(module color mzscheme
+  (require (lib "class.ss")
+           (lib "etc.ss")
+           (lib "unitsig.ss")
+           (lib "mred.ss" "mred")
+           (lib "token-tree.ss" "syntax-color")
+           (lib "paren-tree.ss" "syntax-color")
+           "sig.ss"
+           "../macro.ss")
+           
+  
+  (provide color@)
+  
+  (define color@
+    (unit/sig framework:color^
+      (import [preferences : framework:preferences^]
+              [icon : framework:icon^]
+              [mode : framework:mode^]
+              [text : framework:text^])
+  
+      (rename [-text<%> text<%>]
+              [-text% text%]
+              [-text-mode<%> text-mode<%>])
+      
+      (define-local-member-name set-start-pos set-end-pos reset-tokens)
+      
+      (define -text<%>
+        (interface ()
+          start-colorer
+          stop-colorer))
+      
+      (define interactions-mixin<%>
+        (interface ()
+          reset-tokens 
+          set-start-pos
+          set-end-pos))
+          
+      (define text-mixin
+        (mixin (text:basic<%>) (-text<%> interactions-mixin<%>)
+          ;; ---------------------- Lexing state ----------------------------------
+          
+          ;; The tree of valid tokens, starting at start-pos
+          (define tokens (new token-tree%))
+          
+          ;; The tree of tokens that have been invalidated by an edit
+          ;; but might still be valid.
+          (define invalid-tokens (new token-tree%))
+          
+          ;; The position right before the invalid-tokens tree
+          (define invalid-tokens-start +inf.0)
+          
+          ;; The position right before the next token to be read
+          (define current-pos start-pos)
+          
+          ;; The lexer
+          (define get-token #f)
+          
+          ;; If the tree is completed
+          (define up-to-date? #t)
+          
+          (define stopped? #t)
+          
+          ;; ---------------------- Parnethesis matching --------------------------
+          
+          (define pairs '())
+          (define parens (new paren-tree% (matches pairs)))
+          
+          
+          ;; ---------------------- Interactions state ----------------------------
+          ;; The positions right before and right after the area to be tokenized
+          (define start-pos 0)
+          (define end-pos 'end)
+          
+          (define/public (set-start-pos x)
+            (set! start-pos x))
+          (define/public (set-end-pos x)
+            (set! end-pos x))
+          
+          ;; ---------------------- Preferences -----------------------------------
+          (define should-color? #t)
+          (define remove-prefs-callback-thunk #f)
+          (define prefix #f)
+          
+          ;; ---------------------- Multi-threading -------------------------------
+          ;; A list of thunks that color the buffer
+          (define colors null)
+          ;; The thread handle to the background colorer
+          (define background-thread #f)
+          ;; Prevent the background thread from being put to sleep while modifying
+          ;; global state
+          (define lock (make-semaphore 1))
+          
+          (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
+                   get-style-list in-edit-sequence? get-start-position get-end-position
+                   local-edit-sequence? get-styles-fixed has-focus?)
+          (define/public (reset-tokens)
+            (send tokens reset-tree)
+            (send invalid-tokens reset-tree)
+            (set! invalid-tokens-start +inf.0)
+            (set! up-to-date? #t)
+            (set! parens (new paren-tree% (matches pairs)))
+            (set! current-pos start-pos)
+            (set! colors null)
+            (modify))
+          
+          (define (modify)
+            (when background-thread
+              (break-thread background-thread)))
+          
+          (define (color)
+            (unless (null? colors)
+              ((car colors))
+              (set! colors (cdr colors))
+              (color)))
+          
+          (define (sync-invalid)
+            (when (and (not (send invalid-tokens is-empty?))
+                       (< invalid-tokens-start current-pos))
+              (send invalid-tokens search-min!)
+              (let ((length (send invalid-tokens get-root-length)))
+                (send invalid-tokens remove-root!)
+                (set! invalid-tokens-start (+ invalid-tokens-start length)))
+              (sync-invalid)))
+          
+          ;; re-tokenize should be called with breaks enabled and exit with breaks disabled
+          ;; re-tokenize should be called when lock is not held.  When it exits, the lock
+          ;;   will be held.
+          (define (re-tokenize in in-start-pos)
+            (let-values (((type data new-token-start new-token-end) (get-token in)))
+              ;; breaks must be disabled before the semaphore wait so we can't be
+              ;; broken out of the critical section
+              (break-enabled #f)
+              ;; If a break occurs while we are suspended, the break will occur
+              ;; and the critical section will not be entered
+              (semaphore-wait/enable-break lock)
+              (unless (eq? 'eof type)
+                (let ((len (- new-token-end new-token-start)))
+                  (set! current-pos (+ len current-pos))
+                  (sync-invalid)
+                  (when (and should-color? (not (eq? 'white-space type)))
+                    (set! colors (cons
+                                  (let ((color (preferences:get (string->symbol (format "syntax-coloring:~a:~a"
+                                                                                        prefix
+                                                                                        type))))
+                                        (sp (+ in-start-pos (sub1 new-token-start)))
+                                        (ep (+ in-start-pos (sub1 new-token-end))))
+                                    (lambda ()
+                                      (change-style color sp ep #f)))
+                                  colors)))
+                  (insert-last! tokens (new token-tree% (length len) (data data)))
+                  (send parens add-token data len)
+                  (cond
+                    ((and (not (send invalid-tokens is-empty?))
+                          (= invalid-tokens-start current-pos))
+                     (send invalid-tokens search-max!)
+                     (send parens merge-tree (send invalid-tokens get-root-end-position))
+                     (insert-last! tokens invalid-tokens)
+                     (set! invalid-tokens-start +inf.0))
+                    (else
+                     (semaphore-post lock)
+                     (break-enabled #t)
+                     (re-tokenize in in-start-pos)))))))
+          
+          (define (do-insert/delete edit-start-pos change-length)
+            (unless stopped?
+              (when (> edit-start-pos start-pos)
+                (set! edit-start-pos (sub1 edit-start-pos)))
+              (modify)
+              (cond
+                (up-to-date?
+                 (send tokens search! (- edit-start-pos start-pos))
+                 (let-values (((orig-token-start orig-token-end valid-tree invalid-tree)
+                               (send tokens split)))
+                   (send parens split-tree orig-token-start)
+                   (set! invalid-tokens invalid-tree)
+                   (set! tokens valid-tree)
+                   (set! invalid-tokens-start (+ start-pos orig-token-end change-length))
+                   (set! current-pos (+ start-pos orig-token-start))
+                   (set! up-to-date? #f)
+                   (colorer-callback)))
+                ((>= edit-start-pos invalid-tokens-start)
+                 (send invalid-tokens search! (- edit-start-pos invalid-tokens-start))
+                 (let-values (((tok-start tok-end valid-tree invalid-tree)
+                               (send invalid-tokens split)))
+                   (set! invalid-tokens invalid-tree)
+                   (set! invalid-tokens-start (+ invalid-tokens-start tok-end change-length))))
+                ((>= edit-start-pos current-pos)
+                 (set! invalid-tokens-start (+ change-length invalid-tokens-start)))
+                (else
+                 (send tokens search! (- edit-start-pos start-pos))
+                 (let-values (((tok-start tok-end valid-tree invalid-tree)
+                               (send tokens split)))
+                   (send parens truncate tok-start)
+                   (set! tokens valid-tree)
+                   (set! invalid-tokens-start (+ change-length invalid-tokens-start))
+                   (set! current-pos (+ start-pos tok-start)))))))
+          
+          (define (colorer-callback)
+            (unless (in-edit-sequence?)
+              (thread-resume background-thread)
+              (sleep .01)    ;; This is when the background thread is working.
+              (semaphore-wait lock)
+              (thread-suspend background-thread)
+              (semaphore-post lock)
+              (begin-edit-sequence #f #f)
+              (color)
+              (end-edit-sequence))
+            (unless up-to-date?
+              (queue-callback colorer-callback #f)))
+          
+          
+          ;; Breaks should be disabled on entry
+          (define (background-colorer-entry)
+            (thread-suspend (current-thread))
+            (background-colorer))
+          
+          ;; Breaks should be disabled on entry
+          (define (background-colorer)
+            (let/ec restart
+              (parameterize ((current-exception-handler
+                              (lambda (exn)
+                                ;; Lock is not held here because breaks are disabled
+                                ;; whenever lock is held
+                                (break-enabled #f)
+                                (restart))))
+                (break-enabled #t)
+                (with-handlers ((not-break-exn?
+                                 (lambda (exn)
+                                   (printf "~a~n" exn)
+                                   (break-enabled #f)
+                                   (semaphore-wait lock))))
+                  (re-tokenize (open-input-text-editor this current-pos end-pos)
+                               current-pos))
+                ;; Breaks should be disabled from exit of re-tokenize
+                ;; lock will be held
+                (set! up-to-date? #t)
+                (semaphore-post lock)
+                (thread-suspend (current-thread))))
+            (background-colorer))
+          
+          (define/public (start-colorer prefix- get-token- pairs-)
+            (set! stopped? #f)
+            (reset-tokens)
+            (set! prefix prefix-)
+            (set! get-token get-token-)
+            (set! pairs pairs-)
+            (set! parens (new paren-tree% (matches pairs)))
+            (unless remove-prefs-callback-thunk
+              (set! remove-prefs-callback-thunk
+                    (preferences:add-callback
+                     (string->symbol (format "syntax-coloring:~a:active" prefix))
+                     (lambda (_ on?)
+                       (set! should-color? on?)
+                       (cond
+                         (on?
+                          (reset-tokens)
+                          (do-insert/delete start-pos 0))
+                         (else (change-style (send (get-style-list) find-named-style "Standard")
+                                             start-pos end-pos #f)))))))
+            (unless background-thread
+              (break-enabled #f)
+              (set! background-thread (thread (lambda () (background-colorer-entry))))
+              (break-enabled #t))
+            (do-insert/delete start-pos 0))
+          
+          (define/public (stop-colorer)
+            (set! stopped? #t)
+            (when remove-prefs-callback-thunk
+              (remove-prefs-callback-thunk)
+              (set! remove-prefs-callback-thunk #f))
+            (change-style (send (get-style-list) find-named-style "Standard")
+                          start-pos end-pos #f)
+            (match-parens #t)
+            (reset-tokens)
+            (set! pairs null)
+            (set! prefix #f)
+            (set! get-token #f))
+          
+          
+          ;; ----------------------- Match parentheses ----------------------------
+          
+          (define clear-old-locations 'dummy)
+          (set! clear-old-locations void)
+          
+          (define mismatch-color (make-object color% "PINK"))
+          (define (get-match-color) (preferences:get 'framework:paren-match-color))
+          
+          (define (highlight start end caret-pos error?)
+            (let ([off (highlight-range (+ start-pos start) (+ start-pos end)
+                                        (if error? mismatch-color (get-match-color))
+                                        (and (send (icon:get-paren-highlight-bitmap) ok?)
+                                             (icon:get-paren-highlight-bitmap))
+                                        (= caret-pos (+ start-pos start)))])
+              (set! clear-old-locations
+                    (let ([old clear-old-locations])
+                      (lambda ()
+                        (old)
+                        (off))))))
+          
+          (define in-match-parens? #f)
+          
+          (define match-parens
+            (opt-lambda ([just-clear? #f])
+              (unless in-match-parens?
+                (set! in-match-parens? #t)
+                (begin-edit-sequence #f #f)
+                (clear-old-locations)
+                (set! clear-old-locations void)
+                (when (preferences:get 'framework:highlight-parens)
+                  (unless just-clear?
+                    (let* ((here (get-start-position)))
+                      (when (= here (get-end-position))
+                        (let-values (((start-f end-f error-f) (send parens match-forward (- here start-pos)))
+                                     ((start-b end-b error-b) (send parens match-backward (- here start-pos))))
+                          (when (and start-f end-f
+                                     (not (and error-f (<= (+ start-pos error-f) current-pos) (not up-to-date?))))
+                            (highlight start-f end-f here error-f))
+                          (when (and start-b end-b)
+                            (highlight start-b end-b here error-b)))))))
+                (end-edit-sequence)
+                (set! in-match-parens? #f))))
+                    
+          ;; ------------------------- Callbacks to Override ----------------------
+          
+          (rename (super-on-focus on-focus))
+          (define/override (on-focus on?)
+            (super-on-focus on?)
+            (match-parens (not on?)))
+          
+          (rename (super-on-change on-change))
+          (define/override (on-change)
+            (modify))
+          
+          (rename (super-after-edit-sequence after-edit-sequence))
+          (define/override (after-edit-sequence)
+            (super-after-edit-sequence)
+            (when (has-focus?)
+              (match-parens)))
+          
+          (rename (super-after-set-position after-set-position))
+          (define/override (after-set-position)
+            (super-after-set-position)
+            (unless (local-edit-sequence?)
+              (when (has-focus?)
+                (match-parens)))
+            (modify))
+          
+          (rename (super-after-change-style after-change-style))
+          (define/override (after-change-style a b)
+            (super-after-change-style a b)
+            (unless (get-styles-fixed)
+              (unless (local-edit-sequence?)
+                (when (has-focus?)
+                  (match-parens))))
+            (modify))
+          
+          (rename (super-on-set-size-constraint on-set-size-constraint))
+          (define/override (on-set-size-constraint)
+            (super-on-set-size-constraint)
+            (unless (local-edit-sequence?)
+              (when (has-focus?)
+                (match-parens)))
+            (modify))
+          
+          (rename (super-after-insert after-insert))
+          (define/override (after-insert edit-start-pos change-length)
+            (do-insert/delete edit-start-pos change-length)
+            (super-after-insert edit-start-pos change-length))
+          
+          (rename (super-after-delete after-delete))
+          (define/override (after-delete edit-start-pos change-length)
+            (do-insert/delete edit-start-pos (- change-length))
+            (super-after-delete edit-start-pos change-length))
+          
+          (super-instantiate ())))
+      
+      (define -text% (text-mixin text:keymap%))
+              
+      (define -text-mode<%> (interface ()))
+      
+      (define text-mode-mixin
+        (mixin (mode:surrogate-text<%>) (-text-mode<%>)
+          ;; get-token takes an input port and returns 4 values:
+          ;; A symbol in `(keyword string literal comment error identifier default)
+          ;; Data to be kept with the token
+          ;; The token's starting offset
+          ;; The token's ending offset
+          ;;
+          ;; matches is a list of lists of matching paren types.
+          ;; For example, '((|(| |)|) (|[| |]|))
+          (init-field get-token prefix (matches null))
+          
+          (rename (super-on-disable-surrogate on-disable-surrogate))
+          (define/override (on-disable-surrogate text)
+            (super-on-disable-surrogate text)
+            (send text stop-colorer))
+          
+          (rename (super-on-enable-surrogate on-enable-surrogate))
+          (define/override (on-enable-surrogate text)
+            (super-on-enable-surrogate text)
+            (send text start-colorer prefix get-token matches))
+          
+          (super-instantiate ())))
+  
+      (define text-mode% (text-mode-mixin mode:surrogate-text%))
+      
+      (define (interactions-mixin %)
+        (class % 
+            
+          (rename (super-do-eval do-eval)
+                  (super-insert-prompt insert-prompt)
+                  (super-initialize-console initialize-console)
+                  (super-reset-console reset-console))
+          
+          (inherit reset-tokens get-prompt-position set-start-pos set-end-pos)
+          
+          (define/override (do-eval start end)
+            (super-do-eval start end)
+            (set-end-pos this end))
+          
+          (define/override (insert-prompt)
+            (super-insert-prompt)
+            (set-end-pos 'end)
+            (set-start-pos (get-prompt-position))
+            (reset-tokens))
+          
+          (define/override (initialize-console)
+            (super-initialize-console)
+            (set-start-pos 0)
+            (set-end-pos 'end)
+            (reset-tokens))
+          
+          (define/override (reset-console)
+            (super-reset-console)
+            (set-start-pos 0)
+            (set-end-pos 'end)
+            (reset-tokens))
+          (super-instantiate ())))
+    )))
+    
\ No newline at end of file
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 3c1463c3..4b8fb6db 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -13,7 +13,8 @@
 	   (lib "list.ss")
 	   (lib "thread.ss")
            (lib "etc.ss")
-           (lib "surrogate.ss"))
+           (lib "surrogate.ss")
+           (lib "scheme-lexer.ss" "syntax-color"))
   
   (provide scheme@)
   
@@ -30,12 +31,26 @@
               [editor : framework:editor^]
               [frame : framework:frame^]
               [comment-box : framework:comment-box^]
-              [mode : framework:mode^])
+              [mode : framework:mode^]
+              [color : framework:color^]
+              [color-prefs : framework:color-prefs^])
       
       (rename [-text-mode<%> text-mode<%>]
               [-text<%> text<%>]
               [-text% text%])
       
+      
+      
+      (color-prefs:add
+       "Scheme Color"
+       `((keyword ,(color-prefs:make-style-delta "Black" #f #f #f))
+         (string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
+         (literal ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
+         (comment ,(color-prefs:make-style-delta "DimGray" #f #f #f))
+         (error ,(color-prefs:make-style-delta "Red" #f #f #f))
+         (identifier ,(color-prefs:make-style-delta "Navy" #f #f #f))
+         (other ,(color-prefs:make-style-delta "brown" #f #f #f))))
+
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       ;;                                                                  ;;
       ;;                           Sexp Snip                              ;;
@@ -260,7 +275,6 @@
       
       (define -text<%>
         (interface ()
-          highlight-parens
           get-limit
           balance-quotes
           balance-parens
@@ -318,7 +332,7 @@
           (send style-list find-named-style "Matching Parenthesis Style")))
 
       (define text-mixin
-        (mixin (text:basic<%> mode:host-text<%>) (-text<%>)
+        (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
           (inherit begin-edit-sequence
                    delete
                    end-edit-sequence
@@ -374,8 +388,6 @@
           [define backward-cache (make-object match-cache:%)]
           [define forward-cache (make-object match-cache:%)]
           
-          [define in-highlight-parens? #f]
-          
           (inherit get-styles-fixed)
           (inherit has-focus? find-snip split-snip)
           
@@ -403,96 +415,6 @@
                         paren-pos]
                        [else (loop (- semi-pos 1))]))]))))
           
-          [define clear-old-locations 'dummy]
-          (set! clear-old-locations void)
-          
-          (define/public highlight-parens
-            (opt-lambda ([just-clear? #f])
-              (unless in-highlight-parens?
-                (set! in-highlight-parens? #t)
-                (begin-edit-sequence #f #f)
-                (clear-old-locations)
-                (set! clear-old-locations void)
-                (when (preferences:get 'framework:highlight-parens)
-                  (unless just-clear?
-                    (let* ([here (get-start-position)]
-                           [there (get-end-position)]
-                           [slash?
-                            (lambda (before after)
-                              (and (>= before 0)
-                                   (>= after 0)
-                                   (let ([text (get-text before after)])
-                                     (and (string? text)
-                                          (>= (string-length text) 1)
-                                          (char=? #\\ (string-ref text 0))))))]
-                           [is-paren?
-                            (lambda (f)
-                              (lambda (char)
-                                (ormap (lambda (x) (char=? char (string-ref (f x) 0)))
-                                       (scheme-paren:get-paren-pairs))))]
-                           [is-left-paren? (is-paren? car)]
-                           [is-right-paren? (is-paren? cdr)])
-                      (when (= here there)
-                        
-                        ;; before, after : (list number number boolean) 
-                        ;;  numbers indicate the range to highlight
-                        ;;  boolean indicates if it is an errorneous highlight
-                        (let ([before
-                               (cond
-                                 [(and (> here 0)
-                                       (is-right-paren? (get-character (sub1 here)))
-                                       (not (in-single-line-comment? here)))
-                                  (cond
-                                    [(slash? (- here 2) (- here 1)) #f]
-                                    [(scheme-paren:backward-match
-                                      this here (get-limit here)
-                                      backward-cache)
-                                     =>
-                                     (lambda (end-pos) 
-                                       (list end-pos here #f))]
-                                    [else (list (- here 1) here #t)])]
-                                 [else #f])]
-                              [after
-                               (cond
-                                 [(and (is-left-paren? (get-character here))
-                                       (not (in-single-line-comment? here)))
-                                  (cond
-                                    [(slash? (- here 1) here) #f]
-                                    [(scheme-paren:forward-match
-                                      this here (last-position)
-                                      forward-cache)
-                                     =>
-                                     (lambda (end-pos)
-                                       (list here end-pos #f))]
-                                    [else (list here (+ here 1) #t)])]
-                                 [else #f])]
-                              [handle-single
-                               (lambda (single)
-                                 (let* ([left (first single)]
-                                        [right (second single)]
-                                        [error? (third single)]
-                                        [off (highlight-range 
-                                              left
-                                              right
-                                              (if error? mismatch-color (get-match-color))
-                                              (and (send (icon:get-paren-highlight-bitmap) ok?)
-                                                   (icon:get-paren-highlight-bitmap))
-                                              (= there here left))])
-                                   (set! clear-old-locations
-                                         (let ([old clear-old-locations])
-                                           (lambda ()
-                                             (old)
-                                             (off))))))])
-                          
-                          (cond
-                            [(and after before)
-                             (handle-single after)
-                             (handle-single before)]
-                            [after (handle-single after)]
-                            [before (handle-single before)]
-                            [else (void)]))))))
-                (end-edit-sequence)
-                (set! in-highlight-parens? #f))))
           
           (public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
                   tabify-all insert-return calc-last-para 
@@ -1097,58 +1019,11 @@
           ))
       
       (define text-mode-mixin
-        (mixin (mode:surrogate-text<%>) (-text-mode<%>)
-          (rename [super-on-focus on-focus])
-          (define/override (on-focus text super-call on?)
-            (super-on-focus text super-call on?)
-            (send text highlight-parens (not on?)))
-          
-          (rename [super-after-change-style after-change-style])
-          (define/override (after-change-style text super-call start len)
-            (unless (send text local-edit-sequence?)
-              (unless (send text get-styles-fixed)
-                (when (send text has-focus?)
-                  (send text highlight-parens))))
-            (super-after-change-style text super-call start len))
-          
-          (rename [super-after-edit-sequence after-edit-sequence])
-          (define/override (after-edit-sequence text super-call)
-            (super-after-edit-sequence text super-call)
-            (when (send text has-focus?)
-              (send text highlight-parens)))
-          
-          (rename [super-after-insert after-insert])
-          (define/override (after-insert text super-call start size)
-            (unless (send text local-edit-sequence?)
-              (when (send text has-focus?)
-                (send text highlight-parens)))
-            (super-after-insert text super-call start size))
-          
-          (rename [super-after-delete after-delete])
-          (define/override (after-delete text super-call start size)
-            (unless (send text local-edit-sequence?)
-              (when (send text has-focus?)
-                (send text highlight-parens)))
-            (super-after-delete text super-call start size))
-          
-          (rename [super-after-set-size-constraint after-set-size-constraint])
-          (define/override (after-set-size-constraint text super-call)
-            (unless (send text local-edit-sequence?)
-              (when (send text has-focus?)
-                (send text highlight-parens)))
-            (super-after-set-size-constraint text super-call))
-          
-          (rename [super-after-set-position after-set-position])
-          (define/override (after-set-position text super-call)
-            (unless (send text local-edit-sequence?)
-              (when (send text has-focus?)
-                (send text highlight-parens)))
-            (super-after-set-position text super-call))
+        (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
 
           (rename [super-on-disable-surrogate on-disable-surrogate])
           (define/override (on-disable-surrogate text)
             (keymap:remove-chained-keymap text keymap)
-            (send text highlight-parens #t)
             (super-on-disable-surrogate text))
           
           (rename [super-on-enable-surrogate on-enable-surrogate])
@@ -1156,9 +1031,6 @@
 	    (send text begin-edit-sequence)
 	    (super-on-enable-surrogate text)
 	    (send (send text get-keymap) chain-to-keymap keymap #t)
-	    (unless (send text local-edit-sequence?)
-	      (when (send text has-focus?)
-		(send text highlight-parens)))
             
             ;; I don't know about these editor flag settings.
             ;; maybe they belong in drscheme?
@@ -1174,8 +1046,23 @@
             (send text set-styles-fixed #t)
 	    (send text end-edit-sequence))
           
-          (super-instantiate ())))
-
+          (super-new (get-token scheme-lexer-wrapper)
+                     (prefix "Scheme Color")
+                     (matches '((|(| |)|)
+                                (|[| |]|)
+                                (|{| |}|))))))
+      
+      (define (scheme-lexer-wrapper in)
+        (let-values (((type lex start end) (scheme-lexer in)))
+          (cond
+            ((and (eq? type 'identifier)
+                  (hash-table-get (preferences:get 'framework:tabify)
+                                  (string->symbol lex)
+                                  (lambda () #f)))
+             (values 'keyword lex start end))
+            (else
+             (values type lex start end)))))
+      
       (define set-mode-mixin
         (mixin (-text<%> mode:host-text<%>) ()
 	  (super-new)
@@ -1185,9 +1072,9 @@
       (define -text% (set-mode-mixin
 		      (text-mixin
 		       (mode:host-text-mixin
-			text:keymap%))))
+			color:text%))))
 
-      (define text-mode% (text-mode-mixin mode:surrogate-text%))
+      (define text-mode% (text-mode-mixin color:text-mode%))
     
                                                                                            
               ;;                                 ;;                                        
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
index 1804642c..322966f5 100644
--- a/collects/framework/private/sig.ss
+++ b/collects/framework/private/sig.ss
@@ -65,6 +65,12 @@
 	   framework:scheme-paren^
 	   framework:scheme-paren-class^
 	   framework:scheme-paren-fun^
+           framework:color^
+           framework:color-class^
+           framework:color-fun^
+           framework:color-prefs^
+           framework:color-prefs-class^
+           framework:color-prefs-fun^
 	   framework:scheme^
 	   framework:scheme-class^
 	   framework:scheme-fun^
@@ -497,6 +503,31 @@
     ((open framework:scheme-paren-class^)
      (open framework:scheme-paren-fun^)))
 
+  (define-signature framework:color-class^
+    (text<%>
+     text-mixin
+     text%
+
+     text-mode<%>
+     text-mode-mixin
+     text-mode%
+     
+     interactions-mixin))
+  (define-signature framework:color-fun^
+    ())
+  (define-signature framework:color^
+    ((open framework:color-class^)
+     (open framework:color-fun^)))
+  
+  (define-signature framework:color-prefs-class^
+    (make-style-delta add))
+  (define-signature framework:color-prefs-fun^
+    ())
+  (define-signature framework:color-prefs^
+    ((open framework:color-prefs-class^)
+     (open framework:color-prefs-fun^)))
+  
+  
   (define-signature framework:scheme-class^
     (text<%>
      text-mixin